home *** CD-ROM | disk | FTP | other *** search
/ Delphi 2 - Developers' Solutions / Delphi 2 Developers' Solutions.iso / dds / sharware / dynarray / arrays.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-05-25  |  96.2 KB  |  2,887 lines
  1. {+------------------------------------------------------------
  2.  | Unit Arrays
  3.  |
  4.  | Version: 1.1  Last modified: 04/28/96
  5.  |   Changes: 1.0 -> 1.1
  6.  |     Added modifications to compile under Delphi 2.0
  7.  |     Renamed T64KArray to TBaseArray since the limit to 64K
  8.  |     does not apply to the Delphi 2.0 version.
  9.  | Author : P. Below
  10.  | Project: Delphi common objects
  11.  | Description:
  12.  |   This Unit implements a base class for resizeable array types
  13.  |   and a few specific derivatives for the common numeric types.
  14.  |
  15.  |   The array classes in this unit are all limited to a maximum
  16.  |   of 64Kbytes of data in Delphi 1.0. The size of the stored items
  17.  |   determines the maximal number of items. Errors will raise
  18.  |   exceptions, index overflow is only reported if range checking
  19.  |   is on. The index range of each class is 0..MaxIndex, MaxIndex
  20.  |   is a property of all class types.
  21.  |
  22.  |   The classes have iterator methods similar to BP collections.
  23.  |   These iterators can optionally call Application.ProcessMessages
  24.  |   between rounds. This requires usage of the Forms Unit. Since
  25.  |   this would involve a tremendous overhead for non-VCL projects
  26.  |   the correspondig USes clause and the iterator code calling
  27.  |   Application.ProcessMessages is enclosed in $IFDEF DOEVENTS
  28.  |   blocks. If DOEVENTS is defined, the Forms unit will be used.
  29.  |   DOEVENTS IS UNDEFINED BY DEFAULT! You need to define this
  30.  |   symbol in your project to make use of the ability to process
  31.  |   messages inside iterator loops and recompile this unit!
  32.  |   The unit does not make any other use of VCL window objects.
  33.  +------------------------------------------------------------}
  34. Unit Arrays;
  35.  
  36. Interface
  37.  
  38. Uses SysUtils, Classes;
  39.  
  40. Const
  41.   (* the following value is returned by the Find method if the passed
  42.      value could not be found in the array *)
  43.   NOT_FOUND = High( Cardinal );
  44. Type
  45.  
  46.   (* Our virtual array need a function of this type to sort themselves
  47.      and search items. As usual the return type should be < 0 if
  48.      item1 < item2,  > 0 if item1 > item2 and 0 if both are equal. 
  49.      Note that the result is not limited to -1, 0, +1! This allows
  50.      faster comparison. *)
  51.   TCompareProc = Function ( Var item1, item2  ): Integer;
  52.  
  53.   (* these procedural types represent functions that can be called
  54.      from one of the iterator method, like ForEach. Version for stand-
  55.      alone procedure and for object methods are provided. *)
  56.   TIterator          = Procedure( Var Element; index: Cardinal );
  57.   TLocator           = Function( Var Element; index: Cardinal ): Boolean;
  58.   TIteratorMethod    = Procedure( Var Element; index: Cardinal ) of Object;
  59.   TLocatorMethod     = Function( Var Element;
  60.                                  index: Cardinal ): Boolean of Object;
  61.  
  62.   (* This error is raised when Sort or Find are called and a compare proc
  63.      has not been assigned *)
  64.   ECompUndefined = Class( Exception );
  65.   (* This error is raised when two class instances are not comaptible
  66.      for an operation *)
  67.   ETypeMismatch  = Class( Exception );
  68.   (* This error is raised if a textfile is too large to be loaded into
  69.      a TPCharArray or TPStringArray *)
  70.   EFileTooLarge  = Class( Exception );
  71.  
  72.   TSortOrder = ( TS_NONE, TS_ASCENDING, TS_DESCENDING );
  73.  
  74.   (* these flags covern some of the behaviour of array methods *)
  75.   TArrayFlags = ( AF_OwnsData, AF_AutoSize, AF_CanCompare,
  76.                   AF_User1, AF_User2, AF_User3, AF_User4, AF_User5,
  77.                   AF_User6, AF_User7, AF_User8, AF_User9, AF_User10,
  78.                   AF_User11, AF_User12 );
  79.   TArrayFlagSet = Set of TArrayFlags;
  80.  
  81.   (* this notification is used by the store/load from textfile methods
  82.      of the string/pchar array classes *)
  83.   TProgressReporter = Function( pos, max: LongInt; 
  84.                                 Var retain: Boolean ): Boolean of Object;
  85.  
  86.   (* TBaseArray is our base array class. It is limited to a single 64K 
  87.      segment for all items. *)
  88.   TBaseArray = Class( TPersistent )
  89.     private
  90.       FMemory: Pointer;              (* pointer to item buffer *)
  91.       FMemSize,                      (* allocated size of buffer in bytes *)
  92.       FItemSize,                     (* size of individual item in bytes *)
  93.       FMaxIndex: Cardinal;           (* max valid index, zero-based *)
  94.       FSortOrder   : TSortOrder;     (* true if array is considered sorted *)
  95.       FCompareProc : TCompareProc;   (* pointer to compare proc *)
  96.       FFlags   : TArrayFlagSet;      (* ability flags *)
  97.  
  98.       Procedure DefineProperties(Filer: TFiler);
  99.         override;
  100.       Procedure AssignTo( Dest: TPersistent );
  101.         override;
  102.       Function GetMaxCapacity: Cardinal;
  103.       Function GetCapacity: Cardinal;
  104.  
  105.     public
  106.       Procedure SaveToFile( Const Filename: String );
  107.         virtual;
  108.       Procedure LoadFromFile( Const Filename: String );
  109.         virtual;
  110.       Procedure SaveToStream( Stream: TStream );
  111.         virtual;
  112.       Procedure LoadFromStream( Stream: TStream );
  113.         virtual;
  114.       Function GetItemPtr( index: Cardinal ): Pointer;
  115.       Procedure PutItem( index: Cardinal; Var data );
  116.       Procedure GetItem( index: Cardinal; Var data );
  117.       Procedure InvalidateItems( atIndex, numItems: Cardinal );
  118.         virtual;
  119.       Function ValidIndex( index: Cardinal ): Boolean;
  120.       Function ValidateBounds( atIndex: Cardinal;
  121.                                Var numItems: Cardinal): Boolean;
  122.       Constructor Create( itemcount, itemsize: Cardinal ); virtual;
  123.       Destructor  Destroy; override;
  124.       Procedure Zap; virtual;
  125.       Function  Clone: TBaseArray; 
  126.         virtual;
  127.       Procedure ReDim( newcount: Cardinal );
  128.         virtual;
  129.       Procedure Insert( Var Source; atIndex, numItems: Cardinal );
  130.         virtual;
  131.       Procedure Delete( atIndex, numItems: Cardinal );
  132.         virtual;
  133.       Procedure Append( Var Source; numItems: Cardinal );
  134.         virtual;
  135.       Procedure CopyFrom( Var Source; toIndex, numItems: Cardinal );
  136.         virtual;
  137.       Procedure CopyTo( Var Dest; fromIndex, numItems: Cardinal );
  138.         virtual;
  139.       Procedure BlockCopy( Source: TBaseArray; 
  140.                            fromIndex, toIndex, numitems: Cardinal );
  141.         virtual;
  142.       Procedure Sort( ascending: Boolean );
  143.         virtual;
  144.       Function  Find( Var value ): Cardinal;
  145.         virtual;
  146.       Procedure ForEach( iterator: TIteratorMethod; processMsg: Boolean;
  147.                          intervall: Cardinal );
  148.       Function  FirstThat( locator: TLocatorMethod; 
  149.                            processMsg: Boolean;
  150.                            intervall: Cardinal ): Pointer;
  151.       Function  LastThat(locator: TLocatorMethod;
  152.                          processMsg: Boolean;
  153.                          intervall: Cardinal ): Pointer;
  154.       Procedure ForEachProc( iterator: TIterator; processMsg: Boolean;
  155.                              intervall: Cardinal );
  156.       Function  FirstThatProc( locator: TLocator;
  157.                                processMsg: Boolean;
  158.                                intervall: Cardinal ): Pointer;
  159.       Function  LastThatProc(locator: TLocator;
  160.                              processMsg: Boolean;
  161.                              intervall: Cardinal ): Pointer;
  162.       Function GetCount: Cardinal; virtual;
  163.       Procedure SetCompareProc( proc: TCompareProc );
  164.  
  165.       Function HasFlag( aFlag: TArrayFlags ): Boolean;
  166.       Procedure SetFlag( aFlag: TArrayFlags ); 
  167.       Procedure ClearFlag( aFlag: TArrayFlags ); 
  168.  
  169.       property Memory: Pointer read FMemory;
  170.       property MemSize: Cardinal read FMemSize;
  171.       property ItemSize: Cardinal read FItemSize;
  172.       property MaxIndex: Cardinal read FMaxIndex;
  173.       property Count: Cardinal read GetCount;
  174.       property ItemPtr[ Index:Cardinal ]: Pointer read GetItemPtr;
  175.       property SortOrder: TSortOrder read FSortOrder write FSortOrder;
  176.       property CompareProc: TCompareProc read FCompareProc write SetCompareProc;
  177.       property Capacity: Cardinal read GetCapacity;
  178.       property MaxCapacity: Cardinal read GetMaxCapacity;
  179.       property Flags: TArrayFlagSet read FFlags write FFlags;
  180.   End;
  181.   CBaseArray= Class of TBaseArray;
  182.  
  183.   (* Following are a couple of derived classes for the common numeric types.
  184.      Access to items can be done via normal array syntax on the instance
  185.      via the default array property. *)
  186.   TIntegerArray = Class( TBaseArray )
  187.     public
  188.       Constructor Create( itemcount, dummy: Cardinal ); override;
  189.       Procedure PutData( index: Cardinal; value: Integer );
  190.       Function GetData(index: Cardinal): Integer;
  191.  
  192.       property Data[ Index:Cardinal ]: Integer
  193.          read GetData write PutData; default;
  194.   End;
  195.  
  196.   TCardinalArray = Class( TBaseArray )
  197.     public
  198.       Constructor Create( itemcount, dummy: Cardinal ); override;
  199.       Procedure PutData( index: Cardinal; value: Cardinal );
  200.       Function GetData(index: Cardinal): Cardinal;
  201.  
  202.       property Data[ Index:Cardinal ]: Cardinal
  203.          read GetData write PutData; default;
  204.   End;
  205.  
  206.   TLongIntArray = Class( TBaseArray )
  207.     public
  208.       Constructor Create( itemcount, dummy: Cardinal ); override;
  209.       Procedure PutData( index: Cardinal; value: LongInt );
  210.       Function GetData(index: Cardinal): LongInt;
  211.  
  212.       property Data[ Index:Cardinal ]: LongInt
  213.          read GetData write PutData; default;
  214.   End;
  215.  
  216.   TRealArray = Class( TBaseArray )
  217.     public
  218.       Constructor Create( itemcount, dummy: Cardinal ); override;
  219.       Procedure PutData( index: Cardinal; value: Real );
  220.       Function GetData(index: Cardinal): Real;
  221.  
  222.       property Data[ Index:Cardinal ]: Real
  223.          read GetData write PutData; default;
  224.   End;
  225.  
  226.   TSingleArray = Class( TBaseArray )
  227.     public
  228.       Constructor Create( itemcount, dummy: Cardinal ); override;
  229.       Procedure PutData( index: Cardinal; value: Single );
  230.       Function GetData(index: Cardinal): Single;
  231.  
  232.       property Data[ Index: Cardinal ]: Single
  233.          read GetData write PutData; default;
  234.   End;
  235.  
  236.   TDoubleArray = Class( TBaseArray )
  237.     public
  238.       Constructor Create( itemcount, dummy: Cardinal ); override;
  239.       Procedure PutData( index: Cardinal; value: Double );
  240.       Function GetData(index: Cardinal): Double;
  241.  
  242.       property Data[ Index: Cardinal ]: Double
  243.          read GetData write PutData; default;
  244.   End;
  245.  
  246.   TExtendedArray = Class( TBaseArray )
  247.     public
  248.       Constructor Create( itemcount, dummy: Cardinal ); override;
  249.       Procedure PutData( index: Cardinal; value: Extended );
  250.       Function GetData(index: Cardinal): Extended;
  251.  
  252.       property Data[ Index:Cardinal ]: Extended
  253.          read GetData write PutData; default;
  254.   End;
  255.  
  256.   TPointerArray = Class( TBaseArray )
  257.     public
  258.       Constructor Create( itemcount, dummy: Cardinal ); override;
  259.       Procedure PutData( index: Cardinal; value: Pointer );
  260.       Function GetData(index: Cardinal): Pointer;
  261.       Procedure CopyFrom( Var Source; toIndex, numItems: Cardinal );
  262.         override;
  263.       Procedure CopyTo( Var Dest; fromIndex, numItems: Cardinal );
  264.         override;
  265.       Procedure InvalidateItems(atIndex, numItems: Cardinal);
  266.         override;
  267.       Function CloneItem( item: Pointer ): Pointer; virtual;
  268.       Procedure FreeItem( item: Pointer ); virtual;
  269.       Procedure SaveToFile( Const Filename: String );
  270.         override;
  271.       Procedure LoadFromFile( Const Filename: String );
  272.         override;
  273.       Procedure SaveToStream( Stream: TStream );
  274.         override;
  275.       Procedure LoadFromStream( Stream: TStream );
  276.         override;
  277.       Procedure SaveItemToStream( S: TStream; Item: Pointer );
  278.         virtual;
  279.       Procedure LoadItemFromStream( S: TStream; Var Item: Pointer );
  280.         virtual;
  281.  
  282.       property AsPtr[ Index: Cardinal ]: Pointer
  283.          read GetData write PutData;
  284.       property Data[ Index: Cardinal ]: Pointer
  285.          read GetData write PutData;   (* NOT default here! *)
  286.   End;
  287.  
  288.   TPCharArray = Class( TPointerArray )
  289.     public
  290.       Constructor Create( itemcount, dummy: Cardinal ); override;
  291.       Procedure PutData( index: Cardinal; value: PChar );
  292.       Function GetData(index: Cardinal): PChar;
  293.  
  294.       Function CloneItem( item: Pointer ): Pointer;
  295.         override;
  296.       Procedure FreeItem( item: Pointer );
  297.         override;
  298.       Procedure SaveItemToStream( S: TStream; Item: Pointer );
  299.         override;
  300.       Procedure LoadItemFromStream( S: TStream; Var Item: Pointer );
  301.         override;
  302.  
  303.       Procedure PutAsString( index: Cardinal; Const value: String );
  304.       Function GetAsString(index: Cardinal): String;
  305.       Procedure PutAsInteger( index: Cardinal; value: LongInt );
  306.       Function GetAsInteger(index: Cardinal): LongInt;
  307.       Procedure PutAsReal( index: Cardinal; value: Extended );
  308.       Function GetAsReal(index: Cardinal): Extended;
  309.  
  310.       Procedure LoadFromTextfile( Const Filename: String;
  311.                                   appendData: Boolean;
  312.                                   reporter: TProgressReporter );
  313.       Procedure SaveToTextfile( Const Filename: String;
  314.                                   appendData: Boolean;
  315.                                   reporter: TProgressReporter );
  316.  
  317.       property Data[ Index: Cardinal ]: PChar
  318.          read GetData write PutData; Default;
  319.       property AsString[ Index: Cardinal ]: String
  320.          read GetAsString write PutAsString;
  321.       property AsInteger[ Index: Cardinal ]: LongInt
  322.          read GetAsInteger write PutAsInteger;
  323.       property AsReal[ Index: Cardinal ]: Extended
  324.          read GetAsReal write PutAsReal;
  325.  
  326.   End;
  327.  
  328.   TPStringArray = Class( TPointerArray )
  329.     public
  330.       Constructor Create( itemcount, dummy: Cardinal ); override;
  331.       Procedure PutData( index: Cardinal; Const value: String );
  332.       Function GetData(index: Cardinal): String;
  333.  
  334.       Function CloneItem( item: Pointer ): Pointer;
  335.         override;
  336.       Procedure FreeItem( item: Pointer );
  337.         override;
  338.       Procedure SaveItemToStream( S: TStream; Item: Pointer );
  339.         override;
  340.       Procedure LoadItemFromStream( S: TStream; Var Item: Pointer );
  341.         override;
  342.       Function GetAsPtr(index: Cardinal): PString;
  343.       Procedure PutAsPChar( index: Cardinal; value: PChar );
  344.       Function GetAsPChar(index: Cardinal): PChar;
  345.       Procedure PutAsInteger( index: Cardinal; value: LongInt );
  346.       Function GetAsInteger(index: Cardinal): LongInt;
  347.       Procedure PutAsReal( index: Cardinal; value: Extended );
  348.       Function GetAsReal(index: Cardinal): Extended;
  349.       Procedure LoadFromTextfile( Const Filename: String;
  350.                                   appendData: Boolean;
  351.                                   reporter: TProgressReporter );
  352.       Procedure SaveToTextfile( Const Filename: String;
  353.                                   appendData: Boolean;
  354.                                   reporter: TProgressReporter );
  355.  
  356.       property Data[ Index: Cardinal ]: String
  357.          read GetData write PutData; Default;
  358.       property AsPChar[ Index: Cardinal ]: Pchar
  359.          read GetAsPChar write PutAsPChar;
  360.       property AsInteger[ Index: Cardinal ]: LongInt
  361.          read GetAsInteger write PutAsInteger;
  362.       property AsReal[ Index: Cardinal ]: Extended
  363.          read GetAsReal write PutAsReal;
  364.       property AsPString[ Index: Cardinal ]: PString
  365.          read GetAsPtr;
  366.   End;
  367.  
  368.   (* a couple of compare procedures as used by the numeric array classes *)
  369.  
  370.   Function CmpIntegers( Var item1, item2 ): Integer;
  371.   Function CmpCardinals( Var item1, item2  ): Integer;
  372.   Function CmpLongs( Var item1, item2 ): Integer;
  373.   Function CmpReals( Var item1, item2 ): Integer;
  374.   Function CmpSingles( Var item1, item2 ): Integer;
  375.   Function CmpDoubles( Var item1, item2 ): Integer;
  376.   Function CmpExtendeds( Var item1, item2 ): Integer;
  377.   Function CmpPChars( Var item1, item2 ): Integer;
  378.   Function CmpPStrings( Var item1, item2 ): Integer;
  379.  
  380. Implementation
  381.  
  382. {$IFDEF DOEVENTS}
  383. Uses Forms, FastMem, WinProcs;
  384. {$ELSE}
  385. Uses FastMem, WinProcs;
  386. {$ENDIF}
  387.  
  388. Const
  389.   (* This section defines the error messages for exceptions specific to
  390.      the objects in this Unit. Translate as necessary. *)
  391.  
  392.   ErrAssign =
  393.     'TBaseArray.AssignTo: Destination object does not match this array.';
  394.   ErrLoad = 
  395.     'TBaseArray.LoadFromStream: The stored items have different size than'+
  396.     ' this arrays items.';
  397.   ErrCompare =
  398.     'TBaseArray.Sort/Find: No comparision function has been assigned '+
  399.     'for this array object.';
  400.   ErrIndex =
  401.     'TBaseArray: Index %u out of bounds, maximum allowed is %u';
  402.   ErrSegmentOverflow =
  403.     'TBaseArray.ReDim: requested size > 64Kbyte!';
  404.   ErrFileTooLarge =
  405.     'LoadFromTextfile: File %s has too many lines to load completely!';
  406.  
  407. {+----------------------
  408.  | Methods of TBaseArray 
  409.  +----------------------}
  410. {************************************************************
  411.  * TBaseArray.DefineProperties
  412.  *
  413.  * Parameters:
  414.  *  Filer: a storage handler object
  415.  * Description:
  416.  *  This methods prepares the object for streaming by telling the
  417.  *  Filer which methods to call for loading and storing the array
  418.  *  data.
  419.  * Error Conditions:
  420.  *  none
  421.  *
  422.  *Created: 04/18/95 14:33:53 by P. Below
  423.  ************************************************************}
  424. Procedure TBaseArray.DefineProperties(Filer: TFiler); 
  425.   Begin
  426.     inherited DefineProperties( Filer );
  427.     Filer.DefineBinaryProperty( 'ArrayData', LoadFromStream, 
  428.                                 SaveToStream, FMemory <> Nil );
  429.   End; { TBaseArray.DefineProperties }
  430.  
  431. {************************************************************
  432.  * TBaseArray.AssignTo
  433.  *
  434.  * Parameters:
  435.  *  Dest: the target object 
  436.  * Description:
  437.  *  This method copies the contents of this array to the destination
  438.  *  array, provided the destination is a descendant of TBaseArray and
  439.  *  has the same component size. The destination array is redim'ed to 
  440.  *  the same size as this array.  The actual copy is performed by
  441.  *  the BlockCopy method, which a descendant class can override to
  442.  *  realize a deep copy, for instance, if the items stored in the 
  443.  *  array are pointers.
  444.  * Error Conditions:
  445.  *  This method will raise a EConvertError exception, if the type of
  446.  *  the destination does not match that of Self. It may also cause 
  447.  *  a protection fault, if Dest ist Nil ( really stupid! ) or an out
  448.  *  of memory exception in ReDim.
  449.  *
  450.  *Created: 04/18/95 15:01:29 by P. Below
  451.  ************************************************************}
  452. Procedure TBaseArray.AssignTo( Dest: TPersistent );
  453.   Var
  454.     D: TBaseArray absolute Dest;
  455.   Begin
  456.     If ( Dest Is ClassType ) and ( ItemSize = D.ItemSize ) Then Begin
  457.       If D.MaxIndex < MaxIndex Then
  458.         D.Redim( Succ( MaxIndex ) );
  459.       D.BlockCopy( Self, 0, 0, Succ( maxIndex ));
  460.       D.SortOrder := SortOrder;
  461.       D.Flags := Flags;
  462.       D.CompareProc := CompareProc;
  463.     End { If }
  464.     Else
  465.       raise ETypeMismatch.Create( errAssign );
  466.   End; { TBaseArray.AssignTo }
  467.  
  468. Function TBaseArray.GetMaxCapacity: Cardinal;
  469.   Begin
  470.     Result := High( Cardinal ) div ItemSize;
  471.   End; { TBaseArray.GetMaxCapacity }
  472.  
  473. Function TBaseArray.GetCapacity: Cardinal;
  474.   Begin
  475.     Result := Succ( MaxIndex );
  476.   End; { TBaseArray.GetCapacity }
  477.  
  478. {************************************************************
  479.  * TBaseArray.SaveToFile
  480.  *
  481.  * Parameters:
  482.  *  Filename: name of file to write
  483.  * Description:
  484.  *  Saves the data in this array to a file. Only the array data
  485.  *  itself is written, neither the component size not the number 
  486.  *  of items are stored! This makes it possible to access the file
  487.  *  as a File Of Component ( where Component is the type stored in
  488.  *  this array, not a Delphi Component!).
  489.  * Error Conditions:
  490.  *  May raise a EInOutError exception if a file-related error occurs.
  491.  *
  492.  *Created: 05/01/95 16:09:08 by P. Below
  493.  ************************************************************}
  494. Procedure TBaseArray.SaveToFile( Const Filename: String );
  495.   Var
  496.     F: File;
  497.   Begin
  498.     AssignFile( F, Filename );
  499.     Rewrite( F, ItemSize );
  500.     try
  501.       BlockWrite( F, FMemory^, Succ( MaxIndex ));
  502.     finally
  503.       CloseFile( F );
  504.     end;
  505.   End; { TBaseArray.SaveToFile }
  506.  
  507. {************************************************************
  508.  * TBaseArray.LoadFromFile
  509.  *
  510.  * Parameters:
  511.  *  Filename: name of file to load
  512.  * Description:
  513.  *  Loads the contents of the requested file into the array, which
  514.  *  is redimensioned to fit the data.
  515.  *  For this to work smoothly the file should have been created
  516.  *  by the SaveToFile method of an array object of the same type
  517.  *  as this one and it must be < 64KBytes in size! If it is larger
  518.  *  only part of it will be read. If the items in the file do have
  519.  *  a different item size that this array assumes (a fact we cannot
  520.  *  check), the loaded data will propably come out as garbage!
  521.  * Error Conditions:
  522.  *  May raise a EInOutError exception if a file-related error occurs.
  523.  *
  524.  *Created: 05/01/95 16:28:50 by P. Below
  525.  ************************************************************}
  526. Procedure TBaseArray.LoadFromFile( Const Filename: String );
  527.   Var
  528.     F: File;
  529.     N: LongInt;
  530.   Begin
  531.     AssignFile( F, Filename );
  532.     FileMode := fmOpenRead or fmShareDenyWrite;
  533.     try
  534.       Reset( F, ItemSize );
  535.       N := FileSize( F );
  536.       If (N*ItemSize) > LongInt( High( Cardinal )) Then
  537.         N := High( Cardinal ) div ItemSize;
  538.       Redim( N );
  539.       BlockRead( F, FMemory^, Succ( MaxIndex ));
  540.     finally
  541.       FileMode := 2;
  542.       CloseFile( F );
  543.     end;
  544.   End; { TBaseArray.LoadFromFile }
  545.  
  546. {************************************************************
  547.  * TBaseArray.SaveToStream
  548.  *
  549.  * Parameters:
  550.  *  Stream: an opened stream that takes the array data
  551.  * Description:
  552.  *  This method stores the arrays item size and max index
  553.  *  (NOT the number of items!) followed by the array data into
  554.  *  the passed stream. NOTE that this is different from SaveToFile,
  555.  *  which only writes the array data! 
  556.  *  You can use this method to append the array data to an open 
  557.  *  stream that can already contain other data in front and receive
  558.  *  additional data after we are done here.
  559.  *  We do not stream the array object itself, only its data!
  560.  * Error Conditions:
  561.  *  The stream may raise an exception if it runs into problems.
  562.  *
  563.  *Created: 05/01/95 16:53:49 by P. Below
  564.  ************************************************************}
  565. Procedure TBaseArray.SaveToStream( Stream: TStream );
  566.   Var
  567. {$IFDEF WIN32}
  568.     TempSize, TempIndex: Cardinal;
  569. {$ELSE}
  570.     TempSize, TempIndex: LongInt;
  571. {$ENDIF}
  572.   Begin
  573.     TempSize := FItemSize;
  574.     TempIndex := FMaxIndex;
  575.     With Stream Do Begin
  576.       Write( TempSize, Sizeof( TempSize ));
  577.       Write( TempIndex, Sizeof( TempIndex ));
  578.       Write( FMemory^, FMemSize );
  579.     End; { With }
  580.   End; { TBaseArray.SaveToStream }
  581.  
  582. {************************************************************
  583.  * TBaseArray.LoadFromStream
  584.  *
  585.  * Parameters:
  586.  *  Stream: an opened stream that holds the array data to read
  587.  * Description:
  588.  *  This method reads the stored arrays item size and max index
  589.  *  and checks the item size vs. our own item size. If these two
  590.  *  do match, the array is redimensioned according to the needed
  591.  *  size and the array data are read from the passed stream. 
  592.  *  NOTE that this is different from LoadFromFile, which only 
  593.  *  reads the array data and assumes they have the right item size!
  594.  *  You can use this method to get the array data from an open 
  595.  *  stream that can already contain other data in front and
  596.  *  additional data after. However, it is your responsibility
  597.  *  to position the stream pointer correctly.
  598.  * Error Conditions:
  599.  *  The stream may raise an exception if it runs into problems.
  600.  *  We will raise an ETypeMismatch exception if the item size read
  601.  *  from the stream does not match our own item size. 
  602.  *
  603.  *Created: 05/01/95 16:53:49 by P. Below
  604.  ************************************************************}
  605. Procedure TBaseArray.LoadFromStream( Stream: TStream );
  606.   Var
  607. {$IFDEF WIN32}
  608.     TempSize, TempIndex: Cardinal;
  609. {$ELSE}
  610.     TempSize, TempIndex: LongInt;
  611. {$ENDIF}
  612.   Begin
  613.     Zap;
  614.     With Stream Do Begin
  615.       Read( TempSize, Sizeof( TempSize ));
  616.       Read( TempIndex, Sizeof( TempIndex ));
  617.       If TempSize = ItemSize Then Begin
  618.         Redim( Succ( TempIndex ));
  619.         Read( FMemory^, FMemSize );
  620.       End { If }
  621.       Else
  622.         raise ETypeMismatch.Create( errLoad );
  623.     End; { With }
  624.   End; { TBaseArray.LoadFromStream }
  625.  
  626. {************************************************************
  627.  * TBaseArray.GetItemPtr
  628.  *
  629.  * Parameters:
  630.  *  index: index ( zero-based ) of the item to access
  631.  * Returns:
  632.  *  a pointer to the requested item in this array
  633.  * Description:
  634.  *  Does brute-force pointer arithmetic to calculate the
  635.  *  items address from index and size. 
  636.  *  WARNING! Does no checks for FMemory=Nil! 
  637.  * Error Conditions:
  638.  *  If the passed index is out of range, the method will raise
  639.  *  an ERangeError exception, if range checking is enabled,
  640.  *  otherwise it returns a pointer to the first item in the 
  641.  *  array.
  642.  *
  643.  *Created: 04/18/95 15:56:08 by P. Below
  644.  ************************************************************}
  645. Function TBaseArray.GetItemPtr( index: Cardinal ): Pointer; 
  646.   Begin
  647.     Result := FMemory;
  648.     If ValidIndex( index ) Then
  649. {$IFDEF WIN32}
  650.       Inc( PChar(Result), index*FItemSize )
  651. {$ELSE}
  652.       Inc( PtrRec( Result ).ofs, index*FItemSize )
  653. {$ENDIF}
  654.   End; { TBaseArray.GetItemPtr }
  655.  
  656. {************************************************************
  657.  * TBaseArray.GetCount
  658.  *
  659.  * Parameters:
  660.  *  none
  661.  * Returns:
  662.  *  the number of used items in the array
  663.  * Description:
  664.  *  This method is used to implement the Count property. For
  665.  *  this class it acts like Capacity, because all items of the
  666.  *  array are considered in use. But for a descendant class that
  667.  *  works more like a BP collection, only part of the items
  668.  *  may be actually used. These classes can override GetCount to
  669.  *  return the actually used number. The Count property is used
  670.  *  by Sort, Find and the iterator methods to get the upper bound
  671.  *  of the range to operate on; these methods will thus work
  672.  *  without changes in collection-like descendants.
  673.  * Error Conditions:
  674.  *  none
  675.  *
  676.  *Created: 05/20/95 18:07:46 by P. Below
  677.  ************************************************************}
  678. Function TBaseArray.GetCount: Cardinal;
  679.   Begin
  680.     Result := Succ( FMaxIndex )
  681.   End;
  682.  
  683. {************************************************************
  684.  * TBaseArray.PutItem
  685.  *
  686.  * Parameters:
  687.  *  data: a data item to put into the array, must have same 
  688.  *        size as the arrays components.
  689.  *  index: index of array slot to put the data into ( zero-based )
  690.  * Description:
  691.  *  Uses a direct mem copy to put the data into the array. No
  692.  *  error checks on type of the passed data are possible here!
  693.  *  NOTE:
  694.  *  The method obviously overwrites the old contents of the index
  695.  *  slot but it does _not_ invalidate the old entry! Thus this 
  696.  *  method can be used by an InvalidateItems handler to set a
  697.  *  pointer to Nil.
  698.  * Error Conditions:
  699.  *  If the index is out ouf bounds, does nothing.
  700.  *
  701.  *Created: 04/18/95 16:10:14 by P. Below
  702.  ************************************************************}
  703. Procedure TBaseArray.PutItem(index: Cardinal; Var data );
  704.   Begin
  705.     If ValidIndex( index ) Then Begin
  706.       MemMove( @data, GetItemPtr( index ), FItemSize );
  707.       SortOrder := TS_NONE;
  708.     End;
  709.   End; { TBaseArray.PutItem }
  710.  
  711. { Same as above, only on reverse gear }
  712. Procedure TBaseArray.GetItem( index: Cardinal; Var data );
  713.   Begin
  714.     If ValidIndex( index ) Then
  715.       MemMove( GetItemPtr( index ), @data, FItemSize );
  716.   End; { TBaseArray.GetItem }
  717.  
  718. {************************************************************
  719.  * TBaseArray.Create
  720.  *
  721.  * Parameters:
  722.  *  itemcount: number of items the array should hold, cannot be
  723.  *             0! 0 is mapped to 1.
  724.  *  itemsize : size in bytes of an individual item
  725.  * Description:
  726.  *  Allocates the memory for the array and sets the fields
  727.  *  according to the passed data. In the Win16 version the
  728.  *  product of itemcount and itemsize has to be < 64Kbyte. 
  729.  *  We reduce the itemcount to an allowed value, if necessary,
  730.  *  without raising any error if it is to large.
  731.  * Error Conditions:
  732.  *  If GetMem fails we rely on the default exception handling to
  733.  *  fail the constructor.
  734.  *
  735.  *Created: 04/18/95 16:30:08 by P. Below
  736.  ************************************************************}
  737. Constructor TBaseArray.Create( itemcount, itemsize: Cardinal );
  738. {$IFNDEF WIN32}
  739.   Var
  740.     s: LongInt;
  741. {$ENDIF}
  742.   Begin
  743.     inherited Create;
  744.     If itemcount = 0 Then Inc( itemcount );
  745. {$IFNDEF WIN32}
  746.     s := LongInt( itemcount ) * itemsize;
  747.     If s >= $10000 Then Begin
  748.       (* user has math problems, be gracious and reduce itemcount
  749.          to allowed value *)
  750.       itemcount := $FFFF div itemsize;
  751.     End; { If }
  752. {$ENDIF}
  753.     FMemSize := itemcount * itemsize;
  754.     GetMem( FMemory, FMemSize );
  755.     MemFill( FMemory, FMemSize, 0 );
  756.     FItemSize := itemsize;
  757.     FMaxIndex := Pred( itemcount );
  758.     FFlags    := [ AF_OwnsData, AF_AutoSize ];
  759.   End; { TBaseArray.Create }
  760.  
  761. {************************************************************
  762.  * TBaseArray.Destroy
  763.  *
  764.  * Parameters:
  765.  *  none
  766.  * Description:
  767.  *  Standard destructor, frees the memory allocated for the array
  768.  *  and then calls the inherited destructor. We invalidate all used
  769.  *  items first.
  770.  * Error Conditions:
  771.  *  none
  772.  *
  773.  *Created: 04/18/95 16:34:35 by P. Below
  774.  ************************************************************}
  775. Destructor  TBaseArray.Destroy; 
  776.   Begin
  777.     If FMemory <> Nil Then Begin
  778.       InvalidateItems( 0, Count );
  779.       FreeMem( FMemory, FMemSize );
  780.       FMemSize := 0;
  781.       FMaxIndex := 0;
  782.       FItemSize := 0;
  783.     End; { If }
  784.     inherited Destroy;
  785.   End; { TBaseArray.Destroy }
  786.  
  787. (* Invalidate all used items and fill the memory with 0 *)
  788. Procedure TBaseArray.Zap;
  789.   Begin
  790.     InvalidateItems( 0, Count );
  791.     MemFill( Memory, Capacity*ItemSize, 0 );
  792.   End; { TBaseArray.Zap }
  793.  
  794. {************************************************************
  795.  * TBaseArray.Clone
  796.  *
  797.  * Parameters:
  798.  *  none
  799.  * Returns:
  800.  *  Pointer to a freshly minted exact copy of this object
  801.  * Description:
  802.  *  Creates a new object of the same type as this one is and
  803.  *  copies the arrays contents to the new object via AssignTo.
  804.  *  If the actual class type stores pointers to other stuff it
  805.  *  is the responsibility of that class to override the BlockCopy
  806.  *  method used by AssignTo to implement a deep copy.
  807.  * Error Conditions:
  808.  *  Construction of the new object may fail due to out of memory.
  809.  *  The assign process may conceivably also fail, if it involves
  810.  *  a deep copy. If that happens, the raised exception is trapped,
  811.  *  the new object destroyed and the exception is reraised for
  812.  *  handling at an upper level.
  813.  *
  814.  *Created: 04/18/95 16:46:35 by P. Below
  815.  ************************************************************}
  816. Function  TBaseArray.Clone: TBaseArray;
  817.   Var
  818.     cI : CBaseArray;
  819.   Begin
  820.     cI := CBaseArray(Self.ClassType);
  821.     Result := cI.Create( Succ( FMaxIndex ), FItemSize );
  822.     try
  823.       AssignTo( Result );
  824.     except
  825.       on EOutOfMemory Do Begin
  826.         Result.Free;
  827.         Result := Nil;
  828.         raise
  829.       end;
  830.     end;
  831.   End; { TBaseArray.Clone }
  832.  
  833. {************************************************************
  834.  * TBaseArray.ReDim
  835.  *
  836.  * Parameters:
  837.  *  newcount: number of items the new array should hold, cannot
  838.  *            be 0! 0 is mapped to 1.
  839.  * Description:
  840.  *  Reallocates the array to a new size. The old items are
  841.  *  copied over, as far as possible. New slots are nulled out.
  842.  *  If the new array is smaller than the old one the extra 
  843.  *  items are invalidated so a derived class can do cleanup
  844.  *  on them.
  845.  * Error Conditions:
  846.  *  ReAllocMem, the RTL function used, may raise an out of memory
  847.  *  exception.
  848.  *  If compiled with debugging on ($D+) we will raise an ERangeError
  849.  *  exception, if the requested size is > 64K and we are compiling
  850.  *  for Win16.
  851.  *
  852.  *Created: 04/18/95 17:12:12 by P. Below
  853.  ************************************************************}
  854. Procedure TBaseArray.ReDim( newcount: Cardinal );
  855. {$IFNDEF WIN32}
  856.   Var
  857.     s: LongInt;
  858. {$ENDIF}
  859.   Begin
  860.     If newcount = 0 Then Inc( newcount );
  861.     If newcount <> Succ( FMaxIndex ) Then Begin
  862.       If newcount < Succ( FMaxIndex ) Then
  863.         InvalidateItems( newcount, FMaxIndex-newcount+1 )
  864. {$IFNDEF WIN32}
  865.       Else Begin
  866.         s := LongInt( newcount ) * itemsize;
  867.         If s >= $10000 Then Begin
  868.           (* user has math problems, be gracious and reduce newcount
  869.              to allowed value *)
  870.           newcount := GetMaxCapacity;
  871. {$IFOPT D+}
  872.           (* raise an exception, if compiled for debugging *)
  873.           raise 
  874.             ERangeError.Create( ErrSegmentOverflow );
  875. {$ENDIF}
  876.         End; { If }
  877.       End
  878. {$ENDIF}
  879.       ;
  880. {$IFDEF WIN32}
  881.       ReAllocMem( FMemory, newcount * FItemSize );
  882. {$ELSE}
  883.       FMemory := ReAllocMem( FMemory,
  884.                              Succ( FMaxIndex )*FItemSize,
  885.                              newcount * FItemSize );
  886. {$ENDIF}
  887.       FMemSize  := newcount* FItemSize;
  888.       FMaxIndex := Pred( newcount );
  889.       SortOrder := TS_NONE;
  890.     End; { If }
  891.   End; { TBaseArray.ReDim }
  892.  
  893. {************************************************************
  894.  * TBaseArray.InvalidateItems
  895.  *
  896.  * Parameters:
  897.  *  atIndex: index of first item about to be nuked
  898.  *  numItems: number of items effected
  899.  * Description:
  900.  *  This method is called is items are about to be deleted from
  901.  *  the array. It does nothing for this class but descendants 
  902.  *  storing pointers or objects may use it to perform cleanup
  903.  *  tasks for the items about to be deleted.
  904.  * Error Conditions:
  905.  *  none
  906.  *
  907.  *Created: 04/19/95 16:48:42 by P. Below
  908.  ************************************************************}
  909. Procedure TBaseArray.InvalidateItems( atIndex, numItems: Cardinal );
  910.   Begin
  911.     { This is a NOP for this class }
  912.   End; (* TBaseArray.InvalidateItems *)
  913.  
  914. {************************************************************
  915.  * TBaseArray.ValidIndex
  916.  *
  917.  * Parameters:
  918.  *  atIndex: an index value
  919.  * Returns:
  920.  *  true if the index is in range, false otherwise
  921.  * Description:
  922.  *  This method is used by a couple of others to validate an
  923.  *  index.
  924.  * Error Conditions:
  925.  *  If Index is > MaxIndex the method will raise a ERangeError 
  926.  *  exception, if range checking is on, or return false if range
  927.  *  checking is off.
  928.  *
  929.  *Created: 04/19/95 16:58:57 by P. Below
  930.  ************************************************************}
  931. Function TBaseArray.ValidIndex( Index: Cardinal ): Boolean;
  932.   Begin
  933.     Result := True;
  934.     If Index > FMaxIndex Then Begin
  935. {$IFOPT R+}
  936.       raise ERangeError.CreateFmt( ErrIndex, [ index, FMaxIndex ] );
  937. {$ENDIF}
  938.       Result := False;
  939.     End { If }
  940.   End;
  941.  
  942. {************************************************************
  943.  * TBaseArray.ValidateBounds
  944.  *
  945.  * Parameters:
  946.  *  atIndex: an index value
  947.  *  numItems: a item count value
  948.  * Returns:
  949.  *  true if the index is in range, false otherwise
  950.  * Description:
  951.  *  This method is used by a couple of others to validate an
  952.  *  index and make sure that numItems is not higher than the
  953.  *  number of items from position atIndex on to the end of array.
  954.  * Error Conditions:
  955.  *  If atIndex is > MaxIndex the method will raise a ERangeError 
  956.  *  exception, if range checking is on, or return false if range
  957.  *  checking is off.
  958.  *
  959.  *  If the numItem parameter is larger than the number of items
  960.  *  present after position atIndex (inclusive) it is adjusted to 
  961.  *  the maximal number of items possible.
  962.  *  
  963.  *
  964.  *Created: 04/19/95 16:58:57 by P. Below
  965.  ************************************************************}
  966. Function TBaseArray.ValidateBounds( atIndex: Cardinal;
  967.                                   Var numItems: Cardinal): Boolean;
  968.   Begin
  969.     Result := ValidIndex( atIndex );
  970.     If Result Then
  971.       If ( numItems > Succ( FMaxIndex )) or 
  972.          (( maxIndex-numItems+1 ) < atIndex ) Then 
  973.         numItems := FMaxIndex - atIndex + 1;
  974.   End; (* TBaseArray.ValidateBounds *)
  975.  
  976.  
  977. {************************************************************
  978.  * TBaseArray.Insert
  979.  *
  980.  * Parameters:
  981.  *  Source : the source of the new items to insert
  982.  *  atIndex: index to insert the new items at
  983.  *  numItems: number of items to insert
  984.  * Description:
  985.  *  This method inserts the passed items, moving all items from
  986.  *  position atIndex and up numItems positions upwards. The array
  987.  *  grows as needed, if the ability flag AF_AutoSize is set. 
  988.  *  If it cannot grow ( enough ), items may fall off
  989.  *  the end! If atIndex is beyond the end of array, Append is used.
  990.  * Error Conditions:
  991.  *  If the method is asked to insert more items than can fit, the
  992.  *  numItems parameter is adjusted to the maximal number of items 
  993.  *  possible without an exception beeing raised. Redim is used to 
  994.  *  grow the array, to EOutOfMemory is a distinct posibility.
  995.  *
  996.  *Created: 04/19/95 16:03:29 by P. Below
  997.  ************************************************************}
  998. Procedure TBaseArray.Insert( Var Source; atIndex, numItems: Cardinal );
  999.   Var
  1000.     oldCapacity, itemsToMove, moveTargetIndex, lostItems: Cardinal;
  1001.   Begin
  1002.     If numItems = 0 Then
  1003.       Exit;
  1004.  
  1005.     (* check 1: if AtIndex is beyond the end of array, we effectively
  1006.                 do an append! *)
  1007.     If atIndex > MaxIndex Then Begin
  1008.       Append( Source, numItems );
  1009.       Exit;
  1010.     End; { If }
  1011.  
  1012.     oldCapacity := Capacity;
  1013.  
  1014.     (* resize the array, this may not succeed completely if the array
  1015.        would need to grow > 64K in Win16! In that case it will grow 
  1016.        to the maximal possible size. *)
  1017.     If HasFlag( AF_AutoSize ) Then
  1018.       Redim( oldCapacity+numItems );
  1019.  
  1020.     (* check2: correct numItems downwards, if the array could not been
  1021.        grown to the required size. Note one pathological case here: if
  1022.        the original atIndex was > MaxIndex AND the array was already 
  1023.        at maximal size, we will run into an invalid index error on the
  1024.        next statement and end up doing nothing! *)
  1025.     If ValidateBounds( atIndex, numItems ) Then Begin
  1026.       
  1027.       (* move the items after the insertion point up to make room for
  1028.          the new items. *)
  1029.       itemsToMove := oldCapacity - atIndex;
  1030.       If itemsToMove > 0 Then Begin
  1031.         moveTargetIndex := atIndex + numItems;
  1032.         (* Note: ValidateBounds makes sure that moveTargetIndex is at
  1033.                  max MaxIndex+1 ( =Capacity )! *)
  1034.  
  1035.         (* check 3: if any items fall off at the end, invalidate them
  1036.                     and reduce the number to move accordingly. *)
  1037.         If ( Capacity - moveTargetIndex ) < itemsToMove Then Begin
  1038.           lostItems := itemsToMove + moveTargetIndex - Capacity;
  1039.           InvalidateItems( atIndex + itemsToMove-lostItems, lostItems );
  1040.           itemsToMove := itemsToMove - lostItems;
  1041.         End; { If }
  1042.  
  1043.         (* move the items beyond the end of insertion range up *)
  1044.         MemMove( GetItemPtr( atIndex ),
  1045.                  GetItemPtr( moveTargetIndex ),
  1046.                  itemsToMove * ItemSize );
  1047.         (* now null out the places where we will put the new items.
  1048.            this is necessary to prevent the InvalidateItems call for
  1049.            these items CopyFrom will do from barfing, if the items
  1050.            are pointers, for example. *)
  1051.         MemFill( GetItemPtr( atIndex ), numItems*ItemSize, 0 );
  1052.       End; { If }
  1053.       (* move the items to insert into the array *)
  1054.       CopyFrom( Source, atIndex, numItems );
  1055.     End; { If }
  1056.   End; { TBaseArray.Insert }
  1057.  
  1058. {************************************************************
  1059.  * TBaseArray.Delete
  1060.  *
  1061.  * Parameters:
  1062.  *  atIndex: index to start deleting items
  1063.  *  numItems: number of items to delete
  1064.  * Description:
  1065.  *  This method deletes items by moving all items above the
  1066.  *  requested range down numItems slots and redims the array
  1067.  *  to the smaller size, if the ability flag AF_AutoSize is set. 
  1068.  *  The deleted items are invalidated first,
  1069.  *  so descendant class storing pointers or objects can free the storage 
  1070.  *  for the deleted items or do other cleanup tasks, as appropriate.
  1071.  * Error Conditions:
  1072.  *  If atIndex is > MaxIndex the method will raise a ERangeError 
  1073.  *  exception, if range checking is on, or do nothing if range
  1074.  *  checking is off.
  1075.  *
  1076.  *  If the method is asked to delete more items than there are, the
  1077.  *  numItems parameter is adjusted to the maximal number of items 
  1078.  *  possible without an exception beeing raised.
  1079.  *
  1080.  *Created: 04/19/95 16:37:34 by P. Below
  1081.  ************************************************************}
  1082. Procedure TBaseArray.Delete( atIndex, numItems: Cardinal );
  1083.   Begin
  1084.     If numItems = 0 Then 
  1085.       Exit;
  1086.     If ValidateBounds( atIndex, numItems ) Then Begin
  1087.       (* invalidate the items about to be deleted so a derived class 
  1088.          can do cleanup on them. *)
  1089.       InvalidateItems( atIndex, numItems );
  1090.  
  1091.       (* move the items above those we delete down, if there are any *)
  1092.       If ( atIndex+numItems ) <= MaxIndex Then
  1093.         MemMove( GetItemPtr( atIndex+numItems ), 
  1094.                  GetItemPtr( atIndex ),
  1095.                  ( maxIndex-atIndex-numItems+1 )*ItemSize );
  1096.       (* null out the now free slots *)
  1097.       MemFill( GetItemPtr( MaxIndex-numItems+1 ),
  1098.                numItems*ItemSize, 0 ); 
  1099.       If HasFlag( AF_AutoSize ) Then 
  1100.         Redim( Capacity - numItems );
  1101.     End; { If }
  1102.   End; { TBaseArray.Delete }
  1103.  
  1104. {************************************************************
  1105.  * TBaseArray.Append
  1106.  *
  1107.  * Parameters:
  1108.  *  Source : the source of the new items to append
  1109.  *  numItems: number of items to append
  1110.  * Description:
  1111.  *  This method appends the passed items. The array
  1112.  *  grows as needed. If it cannot grow enough, not all items may be
  1113.  *  copied! Note that this method is independant of the settings
  1114.  *  of the AF_AutoSize ability flag!
  1115.  * Error Conditions:
  1116.  *  If the method is asked to append more items than can fit, the
  1117.  *  numItems parameter is adjusted to the maximal number of items 
  1118.  *  possible without an exception beeing raised. Redim may raise
  1119.  *  an EOutOfMemory exception.
  1120.  *
  1121.  *Created: 04/19/95 16:03:29 by P. Below
  1122.  ************************************************************}
  1123. Procedure TBaseArray.Append( Var Source; numItems: Cardinal );
  1124.   Var
  1125.     n: Cardinal;
  1126.   Begin
  1127.     n := Capacity;
  1128.     Redim( n+numItems );
  1129.     CopyFrom( Source, n, numItems );
  1130.   End; { TBaseArray.Append }
  1131.  
  1132. {************************************************************
  1133.  * TBaseArray.CopyFrom
  1134.  *
  1135.  * Parameters:
  1136.  *  Source: source of the items to be copied
  1137.  *  toIndex: index for the first copied item
  1138.  *  numItems: number of items to copy
  1139.  * Description:
  1140.  *  This methods overwrites the next numItems items in this array
  1141.  *  starting at position toIndex with items from the Source. The
  1142.  *  overwritten items are invalidated first.
  1143.  * Error Conditions:
  1144.  *  If toIndex is > MaxIndex the method will raise a ERangeError 
  1145.  *  exception, if range checking is on, or do nothing if range
  1146.  *  checking is off. If the Source memory contains less than the
  1147.  *  specified number of items to copy a protection fault may result.
  1148.  *
  1149.  *  If the method is asked to copy more items than will fit, the
  1150.  *  numItems parameter is adjusted to the maximal number of items 
  1151.  *  possible without an exception beeing raised.
  1152.  *  
  1153.  *
  1154.  *Created: 04/19/95 17:14:49 by P. Below
  1155.  ************************************************************}
  1156. Procedure TBaseArray.CopyFrom( Var Source; toIndex, numItems: Cardinal );
  1157.   Begin
  1158.     If numItems = 0 Then 
  1159.       Exit;
  1160.     If ValidateBounds( toIndex, numItems ) Then Begin
  1161.       (* invalidate the items about to be overwritten so a derived class 
  1162.          can do cleanup on them. *)
  1163.       InvalidateItems( toIndex, numItems );
  1164.  
  1165.       (* do the copy *)
  1166.       MemMove( @Source,
  1167.                GetItemPtr(toIndex ),
  1168.                numItems*ItemSize );
  1169.       SortOrder := TS_NONE;
  1170.     End; { If }
  1171.   End; { TBaseArray.CopyFrom }
  1172.  
  1173. {************************************************************
  1174.  * TBaseArray.CopyTo
  1175.  *
  1176.  * Parameters:
  1177.  *  Dest: memory to copy items to
  1178.  *  fromIndex: index of first item to copy
  1179.  *  numItems: number of items to copy
  1180.  * Description:
  1181.  *  This method copies items from this array to a memory target.
  1182.  *  WARNING!
  1183.  *  This may be a problem if the copied items are pointers or
  1184.  *  objects, since this is a shallow copy and the result will
  1185.  *  be several references to the same memory locations! A derived
  1186.  *  class may have to override this method to deal with this problem.
  1187.  * Error Conditions:
  1188.  *  If fromIndex is > MaxIndex the method will raise a ERangeError 
  1189.  *  exception, if range checking is on, or do nothing if range
  1190.  *  checking is off. If the Dest memory can hold less than the
  1191.  *  specified number of items to copy a protection fault may result.
  1192.  *
  1193.  *  If the method is asked to copy more items than there are, the
  1194.  *  numItems parameter is adjusted to the maximal number of items 
  1195.  *  possible without an exception beeing raised.
  1196.  *
  1197.  *Created: 04/19/95 17:19:07 by P. Below
  1198.  ************************************************************}
  1199. Procedure TBaseArray.CopyTo( Var Dest; fromIndex, numItems: Cardinal );
  1200.   Begin
  1201.     If numItems = 0 Then 
  1202.       Exit;
  1203.     If ValidateBounds( fromIndex, numItems ) Then Begin
  1204.       MemMove( GetItemPtr( fromIndex ), @Dest, 
  1205.                numItems*ItemSize );
  1206.     End; { If }
  1207.   End; { TBaseArray.CopyTo }
  1208.  
  1209. {************************************************************
  1210.  * TBaseArray.BlockCopy
  1211.  *
  1212.  * Parameters:
  1213.  *  Source: an array object instance to copy items from
  1214.  *  fromIndex: index in source of first item to copy
  1215.  *  toIndex: index in self to copy the first item to
  1216.  *  numitems: number of items to copy
  1217.  * Description:
  1218.  *  Uses CopyFrom to do the actual copy process after doing a
  1219.  *  few sanity checks on the source. CopyFrom does the checks
  1220.  *  on the target. The numitems count may be reduced if either
  1221.  *  the source does not have that many items or Self cannot take
  1222.  *  them. 
  1223.  * Error Conditions:
  1224.  *  Will raise a ETypeMismatch exception if the Source object is
  1225.  *  not of the same or a derived type as Self and also if it has
  1226.  *  a different item size. ERangeError exceptions may be raised
  1227.  *  by called methods.
  1228.  *
  1229.  *Created: 04/19/95 17:57:41 by P. Below
  1230.  ************************************************************}
  1231. Procedure TBaseArray.BlockCopy( Source: TBaseArray; 
  1232.                          fromIndex, toIndex, numitems: Cardinal ); 
  1233.   Begin
  1234.     If numitems = 0 Then
  1235.       Exit;
  1236.     If ( Source Is ClassType ) and ( ItemSize = Source.ItemSize ) Then
  1237.     Begin
  1238.       If Source.ValidateBounds( fromIndex, numItems ) Then 
  1239.         CopyFrom( Source.GetItemPtr( fromIndex )^, toIndex, numItems )
  1240.     End
  1241.     Else
  1242.       raise ETypeMismatch.Create( ErrAssign );
  1243.   End; { TBaseArray.BlockCopy }
  1244.  
  1245. {************************************************************
  1246.  * TBaseArray.Sort
  1247.  *
  1248.  * Parameters:
  1249.  *  ascending: defines whether to sort in ascending or descending 
  1250.  *             order
  1251.  * Description:
  1252.  *  This method implements a recursive QuickSort. It can only 
  1253.  *  do its work if a comparison function has been assigned to
  1254.  *  the FCompareProc field. Since this is a generic procedure
  1255.  *  to sort any kind of data, it is possible to get a much 
  1256.  *  better performance for specific data types by reimplementing
  1257.  *  the Sort for this type.
  1258.  * Error Conditions:
  1259.  *  Will raise a ECompUndefined exception if no comparison function
  1260.  *  has been defined. Them method may also run out of memory
  1261.  *  in GetMem while allocating the pivot data buffer.
  1262.  *
  1263.  *Created: 04/22/95 16:02:24 by P. Below
  1264.  ************************************************************}
  1265. Procedure TBaseArray.Sort( ascending: Boolean );
  1266.   Procedure QSort( L, R: Cardinal );
  1267.     Var
  1268.       i, j: Cardinal;
  1269.       pPivot: Pointer;
  1270.     Begin
  1271.       i:= L;
  1272.       j:= R;
  1273.       GetMem( pPivot, ItemSize );
  1274.       try
  1275.         GetItem( ( L+R ) div 2, pPivot^ );
  1276.         Repeat
  1277.           If ascending Then Begin
  1278.             While FCompareProc( GetItemPtr( i )^, pPivot^ ) < 0 Do
  1279.               Inc( i );
  1280.             While FCompareProc( pPivot^, GetItemPtr( j )^ ) < 0 Do
  1281.               Dec( j );
  1282.           End { If }
  1283.           Else Begin
  1284.             While FCompareProc( GetItemPtr( i )^, pPivot^ ) > 0 Do
  1285.               Inc( i );
  1286.             While FCompareProc( pPivot^, GetItemPtr( j )^ ) > 0 Do
  1287.               Dec( j );
  1288.           End; { Else }
  1289.           If i <= j Then Begin
  1290.             MemSwap( GetItemPtr( i ), GetItemPtr( j ), ItemSize );
  1291.             Inc( i );
  1292.             If j > 0 Then Dec( j );
  1293.           End; { If }
  1294.         Until i > j ;
  1295.         If L < j Then QSort( L, j );
  1296.         If i < R Then QSort( i, R );
  1297.       finally
  1298.         FreeMem( pPivot, ItemSize );
  1299.       end;
  1300.     End; { QSort }
  1301.   Begin { Sort }
  1302.     (* do we have anything to do? *)
  1303.     If ( Count = 0 ) or not HasFlag( AF_CanCompare ) Then 
  1304.       Exit;
  1305.     If ascending Then
  1306.       If ( SortOrder = TS_ASCENDING ) Then Exit
  1307.       Else
  1308.     Else 
  1309.       If ( SortOrder = TS_DESCENDING ) Then Exit;
  1310.  
  1311.     (* ok, _can_ we do it? *)
  1312.     If @FCompareProc <> Nil Then Begin
  1313.       QSort( 0, Pred( Count ));
  1314.       If ascending Then
  1315.         SortOrder := TS_ASCENDING
  1316.       Else
  1317.         SortOrder := TS_DESCENDING;
  1318.     End
  1319.     Else
  1320.       raise ECompUndefined.Create( ErrCompare );
  1321.   End; { TBaseArray.Sort }
  1322.  
  1323. {************************************************************
  1324.  * TBaseArray.Find
  1325.  *
  1326.  * Parameters:
  1327.  *  value: item to search for in the array
  1328.  * Returns:
  1329.  *  index of found item or NOT_FOUND when the value is not in array.
  1330.  * Description:
  1331.  *  Depending on the sort state of the array this Function will do
  1332.  *  a binary or sequential search thru the array, using the 
  1333.  *  comparison function supplied in FCompareProc to compare value
  1334.  *  to the current item.
  1335.  *  WARNING! 
  1336.  *  If the list is sorted and contains multiple instances of the same
  1337.  *  value, the search will not necessarily find the _first_ instance
  1338.  *  of this value! This is a general shortcome of binary search; set
  1339.  *  SortOrder to TS_NONE before the search to force sequential search
  1340.  *  if the array contains multiple copies of the same value.
  1341.  *
  1342.  *  Like for the Sort method descendants may gain a considerable 
  1343.  *  improvement in performance if they reimplement this method with
  1344.  *  optimized data access and comparison.
  1345.  * Error Conditions:
  1346.  *  Will raise a ECompUndefined exception if no comparison function
  1347.  *  has been defined.
  1348.  *  
  1349.  *
  1350.  *Created: 04/22/95 16:31:13 by P. Below
  1351.  ************************************************************}
  1352. Function  TBaseArray.Find( Var value ): Cardinal;
  1353.   Function LinearSearch: Cardinal;
  1354.     Var
  1355.       i: Cardinal;
  1356.       p: Pointer;
  1357.     Begin
  1358.       Result := NOT_FOUND;
  1359.       p := FMemory;
  1360.       For i:= 0 To Pred( Count )  Do Begin
  1361.         If FCompareProc( value, p^ ) = 0 Then Begin
  1362.           Result := i;
  1363.           Break;
  1364.         End; { If }
  1365. {$IFDEF WIN32}
  1366.         Inc( PChar(p), ItemSize );
  1367. {$ELSE}
  1368.         Inc( PtrRec( p ).ofs, ItemSize );
  1369. {$ENDIF}
  1370.       End; { For }
  1371.     End; { LinearSearch }
  1372.     Function BinarySearch: Cardinal;
  1373.       Var
  1374.         u,l,i: Cardinal; 
  1375.         n    : Integer;
  1376.         asc  : Boolean;
  1377.       Begin
  1378.         Result := NOT_FOUND;
  1379.         l := 0;
  1380.         u := Pred( Count );
  1381.         asc := SortOrder = TS_ASCENDING;
  1382.         While l <= u Do Begin
  1383.           i := ( l+u ) div 2;
  1384.           n := FCompareProc( value, GetItemPtr( i )^);
  1385.           If n = 0 Then Begin
  1386.             Result := i;
  1387.             Break;
  1388.           End;
  1389.           If l = u Then 
  1390.             Break;
  1391.           If asc xor ( n < 0 )Then 
  1392.             l := i
  1393.           Else
  1394.             u := i;
  1395.         End; { While }  
  1396.       End; { BinarySearch }
  1397.       
  1398.   Begin { Find }
  1399.     Result := NOT_FOUND;
  1400.     If ( Count = 0 ) or not HasFlag( AF_CanCompare ) Then 
  1401.       Exit;
  1402.     If @FCompareProc <> Nil Then Begin
  1403.       If SortOrder = TS_NONE Then
  1404.         Result := LinearSearch
  1405.       Else
  1406.         Result := BinarySearch;
  1407.     End
  1408.     Else
  1409.       raise ECompUndefined.Create( ErrCompare );
  1410.   End; { TBaseArray.Find }
  1411.  
  1412. {************************************************************
  1413.  * TBaseArray.ForEach
  1414.  *
  1415.  * Parameters:
  1416.  *  iterator: an object method adhering to the TIteratorMethod
  1417.  *            prototype defined in the Interface. 
  1418.  *  processMsg: this flag deterimines whether the method will
  1419.  *            call Application.ProcessMessages inside the iterator
  1420.  *            loop
  1421.  *  intervall: determines how often ProcessMessages is called, a
  1422.  *             higher number means messages will be processed less
  1423.  *             often since the method uses (index mod intervall)=0
  1424.  *             as trigger to call ProcessMessages.
  1425.  * Description:
  1426.  *  The method loops over all entries of the array and passes the 
  1427.  *  address of each with its index to the iterator method. 
  1428.  *  If processMsg = True, the method will call ProcessMessages on each 
  1429.  *  intervall'th round of the loop. Note that this only happens when 
  1430.  *  this Unit has been compiled with the symbol DOEVENTS defined!
  1431.  * Error Conditions:
  1432.  *  The method has no error conditions per se but horrible things will
  1433.  *  happen if you call it with a Nil iterator since we do not check
  1434.  *  for this condition!
  1435.  *
  1436.  *Created: 04/22/95 17:07:27 by P. Below
  1437.  ************************************************************}
  1438. Procedure TBaseArray.ForEach( iterator: TIteratorMethod; processMsg: Boolean;
  1439.                              intervall: Cardinal );
  1440.   Var
  1441.     i: Cardinal;
  1442.     p: Pointer;
  1443.   Begin
  1444.     p := FMemory;
  1445.     For i:= 0 To Pred( Count )  Do Begin
  1446.       Iterator( p^, i );
  1447. {$IFDEF WIN32}
  1448.       Inc( PChar(p), ItemSize );
  1449. {$ELSE}
  1450.       Inc( PtrRec( p ).ofs, ItemSize );
  1451. {$ENDIF}
  1452. {$IFDEF DOEVENTS}
  1453.       If processMsg and (( i mod intervall ) = 0) Then
  1454.         Application.ProcessMessages;
  1455. {$ENDIF}
  1456.     End; { For }
  1457.   End; { TBaseArray.ForEach }
  1458.  
  1459. {************************************************************
  1460.  * TBaseArray.FirstThat
  1461.  *
  1462.  * Parameters:
  1463.  *  locator:  an object method adhering to the TLocatorMethod
  1464.  *            prototype defined in the Interface. 
  1465.  *  processMsg: this flag determines whether the method will
  1466.  *            call Application.ProcessMessages inside the iterator
  1467.  *            loop
  1468.  *  intervall: determines how often ProcessMessages is called, a
  1469.  *             higher number means messages will be processed less
  1470.  *             often since the method uses (index mod intervall)=0
  1471.  *             as trigger to call ProcessMessages.
  1472.  * Returns:
  1473.  *  The address of the item for which the locator returned True, or
  1474.  *  Nil if it returned False for all items.
  1475.  * Description:
  1476.  *  The method loops over all entries of the array and passes the 
  1477.  *  address of each with its index to the locator method. The loop
  1478.  *  terminates immediately when the locator method returns True.
  1479.  *  If processMsg = True, the method will call ProcessMessages on each 
  1480.  *  intervall'th round of the loop. Note that this only happens when 
  1481.  *  this Unit has been compiled with the symbol DOEVENTS defined!
  1482.  * Error Conditions:
  1483.  *  The method has no error conditions per se but horrible things will
  1484.  *  happen if you call it with a Nil locator since we do not check
  1485.  *  for this condition!
  1486.  *
  1487.  *Created: 04/22/95 17:07:27 by P. Below
  1488.  ************************************************************}
  1489. Function  TBaseArray.FirstThat( locator: TLocatorMethod; 
  1490.                                processMsg: Boolean;
  1491.                                intervall: Cardinal ): Pointer;
  1492.   Var
  1493.     i: Cardinal;
  1494.     p: Pointer;
  1495.   Begin
  1496.     Result := Nil;
  1497.     p := FMemory;
  1498.     For i:= 0 To Pred( Count )  Do Begin
  1499.       If Locator( p^, i ) Then Begin
  1500.         Result := p;
  1501.         Break
  1502.       End;
  1503. {$IFDEF WIN32}
  1504.       Inc( PChar(p), ItemSize );
  1505. {$ELSE}
  1506.       Inc( PtrRec( p ).ofs, ItemSize );
  1507. {$ENDIF}
  1508. {$IFDEF DOEVENTS}
  1509.       If processMsg and (( i mod intervall ) = 0) Then
  1510.         Application.ProcessMessages;
  1511. {$ENDIF}
  1512.     End; { For }
  1513.   End; { TBaseArray.FirstThat }
  1514.  
  1515. {************************************************************
  1516.  * TBaseArray.LastThat
  1517.  *
  1518.  * Parameters:
  1519.  *  locator:  an object method adhering to the TLocatorMethod
  1520.  *            prototype defined in the Interface. 
  1521.  *  processMsg: this flag determines whether the method will
  1522.  *            call Application.ProcessMessages inside the iterator
  1523.  *            loop
  1524.  *  intervall: determines how often ProcessMessages is called, a
  1525.  *             higher number means messages will be processed less
  1526.  *             often since the method uses (index mod intervall)=0
  1527.  *             as trigger to call ProcessMessages.
  1528.  * Returns:
  1529.  *  The address of the item for which the locator returned True, or
  1530.  *  Nil if it returned False for all items.
  1531.  * Description:
  1532.  *  The method loops over all entries of the array, starting with the
  1533.  *  last item working backwards, and passes the 
  1534.  *  address of each with its index to the locator method. The loop
  1535.  *  terminates immediately when the locator method returns True.
  1536.  *  If processMsg = True, the method will call ProcessMessages on each 
  1537.  *  intervall'th round of the loop. Note that this only happens when 
  1538.  *  this Unit has been compiled with the symbol DOEVENTS defined!
  1539.  * Error Conditions:
  1540.  *  The method has no error conditions per se but horrible things will
  1541.  *  happen if you call it with a Nil locator since we do not check
  1542.  *  for this condition!
  1543.  *
  1544.  *Created: 04/22/95 17:07:27 by P. Below
  1545.  ************************************************************}
  1546. Function  TBaseArray.LastThat(locator: TLocatorMethod; 
  1547.                      processMsg: Boolean;
  1548.                          intervall: Cardinal ): Pointer;
  1549.   Var
  1550.     i: Cardinal;
  1551.     p: Pointer;
  1552.   Begin
  1553.     Result := Nil;
  1554.     p := GetItemPtr( Pred( Count ) );
  1555.     For i:= Pred( Count ) DownTo 0 Do Begin
  1556.       If Locator( p^, i ) Then Begin
  1557.         Result := p;
  1558.         Break
  1559.       End;
  1560. {$IFDEF WIN32}
  1561.       Dec( PChar( p ), ItemSize );
  1562. {$ELSE}
  1563.       Dec( PtrRec( p ).ofs, ItemSize );
  1564. {$ENDIF}
  1565. {$IFDEF DOEVENTS}
  1566.       If processMsg and (( i mod intervall ) = 0) Then
  1567.         Application.ProcessMessages;
  1568. {$ENDIF}
  1569.     End; { For }
  1570.   End; { TBaseArray.LastThat }
  1571.  
  1572. {************************************************************
  1573.  * TBaseArray.ForEachProc
  1574.  *
  1575.  * Parameters:
  1576.  *  iterator: a Procedure adhering to the TIterator
  1577.  *            prototype defined in the Interface. 
  1578.  *  processMsg: this flag deterimines whether the method will
  1579.  *            call Application.ProcessMessages inside the iterator
  1580.  *            loop
  1581.  *  intervall: determines how often ProcessMessages is called, a
  1582.  *             higher number means messages will be processed less
  1583.  *             often since the method uses (index mod intervall)=0
  1584.  *             as trigger to call ProcessMessages.
  1585.  * Description:
  1586.  *  The method loops over all entries of the array and passes the 
  1587.  *  address of each with its index to the iterator method. 
  1588.  *  If processMsg = True, the method will call ProcessMessages on each 
  1589.  *  intervall'th round of the loop. Note that this only happens when 
  1590.  *  this Unit has been compiled with the symbol DOEVENTS defined!
  1591.  * Error Conditions:
  1592.  *  The method has no error conditions per se but horrible things will
  1593.  *  happen if you call it with a Nil iterator since we do not check
  1594.  *  for this condition!
  1595.  *
  1596.  *Created: 04/22/95 17:07:27 by P. Below
  1597.  ************************************************************}
  1598. Procedure TBaseArray.ForEachProc( iterator: TIterator; processMsg: Boolean;
  1599.                          intervall: Cardinal );
  1600.   Var
  1601.     i: Cardinal;
  1602.     p: Pointer;
  1603.   Begin
  1604.     p := FMemory;
  1605.     For i:= 0 To Pred( Count )  Do Begin
  1606.       Iterator( p^, i );
  1607. {$IFDEF WIN32}
  1608.       Inc( PChar( p ), ItemSize );
  1609. {$ELSE}
  1610.       Inc( PtrRec( p ).ofs, ItemSize );
  1611. {$ENDIF}
  1612. {$IFDEF DOEVENTS}
  1613.       If processMsg and (( i mod intervall ) = 0) Then
  1614.         Application.ProcessMessages;
  1615. {$ENDIF}
  1616.     End; { For }
  1617.   End; { TBaseArray.ForEachProc }
  1618.  
  1619. {************************************************************
  1620.  * TBaseArray.FirstThatProc
  1621.  *
  1622.  * Parameters:
  1623.  *  locator:  a Function adhering to the TLocator
  1624.  *            prototype defined in the Interface. 
  1625.  *  processMsg: this flag determines whether the method will
  1626.  *            call Application.ProcessMessages inside the iterator
  1627.  *            loop
  1628.  *  intervall: determines how often ProcessMessages is called, a
  1629.  *             higher number means messages will be processed less
  1630.  *             often since the method uses (index mod intervall)=0
  1631.  *             as trigger to call ProcessMessages.
  1632.  * Returns:
  1633.  *  The address of the item for which the locator returned True, or
  1634.  *  Nil if it returned False for all items.
  1635.  * Description:
  1636.  *  The method loops over all entries of the array and passes the 
  1637.  *  address of each with its index to the locator method. The loop
  1638.  *  terminates immediately when the locator method returns True.
  1639.  *  If processMsg = True, the method will call ProcessMessages on each 
  1640.  *  intervall'th round of the loop. Note that this only happens when 
  1641.  *  this Unit has been compiled with the symbol DOEVENTS defined!
  1642.  * Error Conditions:
  1643.  *  The method has no error conditions per se but horrible things will
  1644.  *  happen if you call it with a Nil locator since we do not check
  1645.  *  for this condition!
  1646.  *
  1647.  *Created: 04/22/95 17:07:27 by P. Below
  1648.  ************************************************************}
  1649. Function  TBaseArray.FirstThatProc( locator: TLocator; 
  1650.                          processMsg: Boolean;
  1651.                          intervall: Cardinal ): Pointer;
  1652.   Var
  1653.     i: Cardinal;
  1654.     p: Pointer;
  1655.   Begin
  1656.     Result := Nil;
  1657.     p := FMemory;
  1658.     For i:= 0 To Pred( Count )  Do Begin
  1659.       If Locator( p^, i ) Then Begin
  1660.         Result := p;
  1661.         Break
  1662.       End;
  1663. {$IFDEF WIN32}
  1664.       Inc( PChar( p ), ItemSize );
  1665. {$ELSE}
  1666.       Inc( PtrRec( p ).ofs, ItemSize );
  1667. {$ENDIF}
  1668. {$IFDEF DOEVENTS}
  1669.       If processMsg and (( i mod intervall ) = 0) Then
  1670.         Application.ProcessMessages;
  1671. {$ENDIF}
  1672.     End; { For }
  1673.   End; { TBaseArray.FirstThatProc }
  1674.  
  1675. {************************************************************
  1676.  * TBaseArray.LastThatProc
  1677.  *
  1678.  * Parameters:
  1679.  *  locator:  a Function adhering to the TLocator
  1680.  *            prototype defined in the Interface. 
  1681.  *  processMsg: this flag determines whether the method will
  1682.  *            call Application.ProcessMessages inside the iterator
  1683.  *            loop
  1684.  *  intervall: determines how often ProcessMessages is called, a
  1685.  *             higher number means messages will be processed less
  1686.  *             often since the method uses (index mod intervall)=0
  1687.  *             as trigger to call ProcessMessages.
  1688.  * Returns:
  1689.  *  The address of the item for which the locator returned True, or
  1690.  *  Nil if it returned False for all items.
  1691.  * Description:
  1692.  *  The method loops over all entries of the array, starting with the
  1693.  *  last item working backwards, and passes the 
  1694.  *  address of each with its index to the locator method. The loop
  1695.  *  terminates immediately when the locator method returns True.
  1696.  *  If processMsg = True, the method will call ProcessMessages on each 
  1697.  *  intervall'th round of the loop. Note that this only happens when 
  1698.  *  this Unit has been compiled with the symbol DOEVENTS defined!
  1699.  * Error Conditions:
  1700.  *  The method has no error conditions per se but horrible things will
  1701.  *  happen if you call it with a Nil locator since we do not check
  1702.  *  for this condition!
  1703.  *
  1704.  *Created: 04/22/95 17:07:27 by P. Below
  1705.  ************************************************************}
  1706. Function  TBaseArray.LastThatProc(locator: TLocator; 
  1707.                        processMsg: Boolean;
  1708.                          intervall: Cardinal ): Pointer;
  1709.   Var
  1710.     i: Cardinal;
  1711.     p: Pointer;
  1712.   Begin
  1713.     Result := Nil;
  1714.     p := GetItemPtr( Pred( Count ) );
  1715.     For i:= Pred( Count ) DownTo 0 Do Begin
  1716.       If Locator( p^, i ) Then Begin
  1717.         Result := p;
  1718.         Break
  1719.       End;
  1720. {$IFDEF WIN32}
  1721.       Dec( PChar( p ), ItemSize );
  1722. {$ELSE}
  1723.       Dec( PtrRec( p ).ofs, ItemSize );
  1724. {$ENDIF}
  1725. {$IFDEF DOEVENTS}
  1726.       If processMsg and (( i mod intervall ) = 0) Then
  1727.         Application.ProcessMessages;
  1728. {$ENDIF}
  1729.     End; { For }
  1730.   End; { TBaseArray.LastThatProc }
  1731.  
  1732. Procedure TBaseArray.SetCompareProc( proc: TCompareProc );
  1733.   Begin
  1734.     FCompareProc := proc;
  1735.     If @proc = Nil Then
  1736.       ClearFlag( AF_CanCompare )
  1737.     Else
  1738.       SetFlag( AF_CanCompare );
  1739.   End; { TBaseArray.SetCompareProc }
  1740.  
  1741. (* The following methods manipulate the FFlags set of array 
  1742.    'abilites'.  *)
  1743. Function TBaseArray.HasFlag( aFlag: TArrayFlags ): Boolean;
  1744.   Begin
  1745.     Result := aFlag In Flags;
  1746.   End; { TBaseArray.HasFlag }
  1747.  
  1748. Procedure TBaseArray.SetFlag( aFlag: TArrayFlags ); 
  1749.   Begin
  1750.     Include( FFLags, aFlag );
  1751.   End; { TBaseArray.SetFlag }
  1752.  
  1753. Procedure TBaseArray.ClearFlag( aFlag: TArrayFlags ); 
  1754.   Begin
  1755.     Exclude( FFLags, aFlag );
  1756.   End; { TBaseArray.ClearFlag }
  1757.  
  1758.  
  1759.  
  1760. {+--------------------------
  1761.  | Methods of TIntegerArray 
  1762.  +-------------------------}
  1763. Type
  1764.   TIArray =Array[ 0..High( Cardinal ) div Sizeof( Integer )-1 ] of Integer;
  1765.   PIArray = ^TIArray;
  1766. Constructor TIntegerArray.Create( itemcount, dummy: Cardinal );
  1767.   Begin
  1768.     inherited Create( itemcount, Sizeof( integer ));
  1769.     CompareProc := CmpIntegers;
  1770.   End; { TIntegerArray.Create }
  1771.  
  1772. Procedure TIntegerArray.PutData( index: Cardinal ; value: Integer );
  1773.   Begin
  1774. {$IFOPT R+}
  1775.     If ValidIndex( index ) Then Begin
  1776. {$ENDIF}
  1777.       PIArray( FMemory )^[ index ] := value;
  1778.       SortOrder := TS_NONE;
  1779. {$IFOPT R+}
  1780.     End;
  1781. {$ENDIF}
  1782.   End; { TIntegerArray.PutData }
  1783.  
  1784. Function TIntegerArray.GetData(index: Cardinal): Integer;
  1785.   Begin
  1786. {$IFOPT R+}
  1787.     If ValidIndex( index ) Then
  1788. {$ENDIF}
  1789.       Result := PIArray( FMemory )^[ index ];
  1790.   End; { TIntegerArray.GetData }
  1791.  
  1792. {+---------------------------
  1793.  | Methods of TCardinalArray
  1794.  +--------------------------}
  1795. Type
  1796.   TCArray =Array[ 0..High( Cardinal ) div Sizeof( Cardinal )-1 ] of Cardinal;
  1797.   PCArray = ^TCArray;
  1798. Constructor TCardinalArray.Create( itemcount, dummy: Cardinal );
  1799.   Begin
  1800.     inherited Create( itemcount, Sizeof( Cardinal ));
  1801.     CompareProc := CmpCardinals;
  1802.   End; { TCardinalArray.Create }
  1803.  
  1804. Procedure TCardinalArray.PutData( index: Cardinal ; value: Cardinal );
  1805.   Begin
  1806. {$IFOPT R+}
  1807.     If ValidIndex( index ) Then Begin
  1808. {$ENDIF}
  1809.       PCArray( FMemory )^[ index ] := value;
  1810.       SortOrder := TS_NONE;
  1811. {$IFOPT R+}
  1812.     End;
  1813. {$ENDIF}
  1814.   End; { TCardinalArray.PutData }
  1815.  
  1816. Function TCardinalArray.GetData(index: Cardinal): Cardinal;
  1817.   Begin
  1818. {$IFOPT R+}
  1819.     If ValidIndex( index ) Then
  1820. {$ENDIF}
  1821.       Result := PCArray( FMemory )^[ index ];
  1822.   End; { TCardinalArray.GetData }
  1823.  
  1824. {+---------------------------
  1825.  | Methods of TLongIntArray
  1826.  +--------------------------}
  1827. Type
  1828.   TLArray = Array[ 0..High( Cardinal ) div Sizeof( LongInt )-1 ] of LongInt;
  1829.   PLArray = ^TLArray;
  1830. Constructor TLongIntArray.Create( itemcount, dummy: Cardinal );
  1831.   Begin
  1832.     inherited Create( itemcount, Sizeof( LongInt ));
  1833.     CompareProc := CmpLongs;
  1834.   End; { TLongIntArray.Create }
  1835.  
  1836. Procedure TLongIntArray.PutData( index: Cardinal ; value: LongInt );
  1837.   Begin
  1838. {$IFOPT R+}
  1839.     If ValidIndex( index ) Then Begin
  1840. {$ENDIF}
  1841.       PLArray( FMemory )^[ index ] := value;
  1842.       SortOrder := TS_NONE;
  1843. {$IFOPT R+}
  1844.     End;
  1845. {$ENDIF}
  1846.   End; { TLongIntArray.PutData }
  1847.  
  1848. Function TLongIntArray.GetData(index: Cardinal): LongInt;
  1849.   Begin
  1850. {$IFOPT R+}
  1851.     If ValidIndex( index ) Then
  1852. {$ENDIF}
  1853.       Result := PLArray( FMemory )^[ index ];
  1854.   End; { TLongIntArray.GetData }
  1855.  
  1856. {+-----------------------
  1857.  | Methods of TRealArray
  1858.  +----------------------}
  1859. Type
  1860.   TRArray = Array[ 0..High( Cardinal ) div Sizeof( Real )-1 ] of Real;
  1861.   PRArray = ^TRArray;
  1862. Constructor TRealArray.Create( itemcount, dummy: Cardinal );
  1863.   Begin
  1864.     inherited Create( itemcount, Sizeof( Real ));
  1865.     CompareProc := CmpReals;
  1866.   End; { TRealArray.Create }
  1867.  
  1868. Procedure TRealArray.PutData( index: Cardinal ; value: Real );
  1869.   Begin
  1870. {$IFOPT R+}
  1871.     If ValidIndex( index ) Then Begin
  1872. {$ENDIF}
  1873.       PRArray( FMemory )^[ index ] := value;
  1874.       SortOrder := TS_NONE;
  1875. {$IFOPT R+}
  1876.     End;
  1877. {$ENDIF}
  1878.   End; { TRealArray.PutData }
  1879.  
  1880. Function TRealArray.GetData(index: Cardinal): Real;
  1881.   Begin
  1882. {$IFOPT R+}
  1883.     If ValidIndex( index ) Then
  1884. {$ENDIF}
  1885.       Result := PRArray( FMemory )^[ index ];
  1886.   End; { TRealArray.GetData }
  1887.  
  1888. {+-------------------------
  1889.  | Methods of TSingleArray
  1890.  +------------------------}
  1891. Type
  1892.   TSArray = Array[ 0..High( Cardinal ) div Sizeof( Single )-1 ] of Single;
  1893.   PSArray = ^TSArray;
  1894. Constructor TSingleArray.Create( itemcount, dummy: Cardinal );
  1895.   Begin
  1896.     inherited Create( itemcount, Sizeof( Single ));
  1897.     CompareProc := CmpSingles;
  1898.   End; { TSingleArray.Create }
  1899.  
  1900. Procedure TSingleArray.PutData( index: Cardinal ; value: Single );
  1901.   Begin
  1902. {$IFOPT R+}
  1903.     If ValidIndex( index ) Then Begin
  1904. {$ENDIF}
  1905.       PSArray( FMemory )^[ index ] := value;
  1906.       SortOrder := TS_NONE;
  1907. {$IFOPT R+}
  1908.     End;
  1909. {$ENDIF}
  1910.   End; { TSingleArray.PutData }
  1911.  
  1912. Function TSingleArray.GetData(index: Cardinal): Single;
  1913.   Begin
  1914. {$IFOPT R+}
  1915.     If ValidIndex( index ) Then
  1916. {$ENDIF}
  1917.       Result := PSArray( FMemory )^[ index ];
  1918.   End; { TSingleArray.GetData }
  1919.  
  1920. {+-------------------------
  1921.  | Methods of TDoubleArray
  1922.  +------------------------}
  1923. Type
  1924.   TDArray = Array[ 0..High( Cardinal ) div Sizeof( Double )-1 ] of Double;
  1925.   PDArray = ^TDArray;
  1926. Constructor TDoubleArray.Create( itemcount, dummy: Cardinal );
  1927.   Begin
  1928.     inherited Create( itemcount, Sizeof( Double ));
  1929.     CompareProc := CmpDoubles;
  1930.   End; { TDoubleArray.Create }
  1931.  
  1932. Procedure TDoubleArray.PutData( index: Cardinal ; value: Double );
  1933.   Begin
  1934. {$IFOPT R+}
  1935.     If ValidIndex( index ) Then Begin
  1936. {$ENDIF}
  1937.       PDArray( FMemory )^[ index ] := value;
  1938.       SortOrder := TS_NONE;
  1939. {$IFOPT R+}
  1940.     End;
  1941. {$ENDIF}
  1942.   End; { TDoubleArray.PutData }
  1943.  
  1944. Function TDoubleArray.GetData(index: Cardinal): Double;
  1945.   Begin
  1946. {$IFOPT R+}
  1947.     If ValidIndex( index ) Then
  1948. {$ENDIF}
  1949.       Result := PDArray( FMemory )^[ index ];
  1950.   End; { TDoubleArray.GetData }
  1951.  
  1952. {+---------------------------
  1953.  | Methods of TExtendedArray
  1954.  +--------------------------}
  1955. Type
  1956.   TEArray = Array[ 0..High( Cardinal ) div Sizeof( Extended )-1 ] of Extended;
  1957.   PEArray = ^TEArray;
  1958. Constructor TExtendedArray.Create( itemcount, dummy: Cardinal );
  1959.   Begin
  1960.     inherited Create( itemcount, Sizeof( Extended ));
  1961.     CompareProc := CmpExtendeds;
  1962.   End; { TExtendedArray.Create }
  1963.  
  1964. Procedure TExtendedArray.PutData( index: Cardinal ; value: Extended );
  1965.   Begin
  1966. {$IFOPT R+}
  1967.     If ValidIndex( index ) Then Begin
  1968. {$ENDIF}
  1969.       PEArray( FMemory )^[ index ] := value;
  1970.       SortOrder := TS_NONE;
  1971. {$IFOPT R+}
  1972.     End;
  1973. {$ENDIF}
  1974.   End; { TExtendedArray.PutData }
  1975.  
  1976. Function TExtendedArray.GetData(index: Cardinal): Extended;
  1977.   Begin
  1978. {$IFOPT R+}
  1979.     If ValidIndex( index ) Then
  1980. {$ENDIF}
  1981.       Result := PEArray( FMemory )^[ index ];
  1982.   End; { TExtendedArray.GetData }
  1983.  
  1984. {+--------------------------
  1985.  | Methods of TPointerArray  
  1986.  +-------------------------}
  1987. Type
  1988.   TPArray = Array [ 0..High( Cardinal ) div Sizeof( Pointer )-1 ] Of Pointer;
  1989.   PPArray = ^TPArray;
  1990.  
  1991. Constructor TPointerArray.Create( itemcount, dummy: Cardinal );
  1992.   Begin
  1993.     inherited Create( itemcount, Sizeof( Pointer ));
  1994.     Flags := [ AF_AutoSize ];
  1995.     (* no comparison function can be assigned here since we do not
  1996.        even know how large the memory areas are our pointers point to. 
  1997.        by default the array will also not own the data it collects. *)
  1998.   End; { TPointerArray.Create }
  1999.  
  2000. {************************************************************
  2001.  * TPointerArray.CopyFrom
  2002.  *
  2003.  * Parameters:
  2004.  *  Source: source of the items to be copied
  2005.  *  toIndex: index for the first copied item
  2006.  *  numItems: number of items to copy
  2007.  * Description:
  2008.  *  This methods overwrites the next numItems items in this array
  2009.  *  starting at position toIndex with _copies_ (hopefully) of items 
  2010.  *  from the Source. The overwritten items are invalidated first.
  2011.  *  The actual copy is done item by item with calls to the CloneItem
  2012.  *  method. The version provided with this calls will only do a shallow
  2013.  *  copy ( it has no idea about what the pointer point to ), so you
  2014.  *  should derive your own class with an overriden CloneItem method 
  2015.  *  to get a deep copy.
  2016.  * Error Conditions:
  2017.  *  If toIndex is > MaxIndex the method will raise a ERangeError 
  2018.  *  exception, if range checking is on, or do nothing if range
  2019.  *  checking is off. If the Source memory contains less than the
  2020.  *  specified number of items to copy a protection fault may result.
  2021.  *
  2022.  *  If the method is asked to copy more items than will fit, the
  2023.  *  numItems parameter is adjusted to the maximal number of items 
  2024.  *  possible without an exception beeing raised.
  2025.  *  
  2026.  *
  2027.  *Created: 05/28/95 21:14:49 by P. Below
  2028.  ************************************************************}
  2029. Procedure TPointerArray.CopyFrom( Var Source; toIndex, numItems: Cardinal );
  2030.   Var
  2031.     i: Cardinal;
  2032.     p: PPArray;
  2033.     arr: TPArray absolute Source;
  2034.   Begin
  2035.     If numItems = 0 Then 
  2036.       Exit;
  2037.     If ValidateBounds( toIndex, numItems ) Then Begin
  2038.       (* invalidate the items about to be overwritten so a derived class 
  2039.          can do cleanup on them. *)
  2040.       InvalidateItems( toIndex, numItems );
  2041.  
  2042.       p := PPArray( Memory );
  2043.       For i:= 0 To Pred( numItems ) Do 
  2044.         p^[ toIndex+i ] := CloneItem( arr[ i ] );
  2045.       SortOrder := TS_NONE;
  2046.     End; { If }
  2047.   End; { TPointerArray.CopyFrom }
  2048.  
  2049. {************************************************************
  2050.  * TPointerArray.CopyTo
  2051.  *
  2052.  * Parameters:
  2053.  *  Dest: memory to copy items to
  2054.  *  fromIndex: index of first item to copy
  2055.  *  numItems: number of items to copy
  2056.  * Description:
  2057.  *  This method copies items from this array to a memory target.
  2058.  *  The items are copied one after the other using the CloneItem
  2059.  *  method. The version in this class does only a shallow copy
  2060.  *  (copies the pointer), since it has no idea what the pointers
  2061.  *   point to. You should override CloneItem in derived classes to
  2062.  *   get a deep copy.
  2063.  * Error Conditions:
  2064.  *  If fromIndex is > MaxIndex the method will raise a ERangeError 
  2065.  *  exception, if range checking is on, or do nothing if range
  2066.  *  checking is off. If the Dest memory can hold less than the
  2067.  *  specified number of items to copy a protection fault may result.
  2068.  *
  2069.  *  If the method is asked to copy more items than there are, the
  2070.  *  numItems parameter is adjusted to the maximal number of items 
  2071.  *  possible without an exception beeing raised.
  2072.  *
  2073.  *Created: 05/28/95 21:19:07 by P. Below
  2074.  ************************************************************}
  2075. Procedure TPointerArray.CopyTo( Var Dest; fromIndex, numItems: Cardinal );
  2076.   Var
  2077.     i: Cardinal;
  2078.     p: PPArray;
  2079.     arr: TPArray absolute Dest;
  2080.   Begin
  2081.     If numItems = 0 Then 
  2082.       Exit;
  2083.     If ValidateBounds( fromIndex, numItems ) Then Begin
  2084.       p := PPArray( Memory );
  2085.       For i:= 0 To Pred( numItems ) Do 
  2086.         arr[ i ] := CloneItem( p^[ fromIndex+i ] );
  2087.     End; { If }
  2088.   End; { TPointerArray.CopyTo }
  2089.  
  2090. (* PutData implements the write access via the default Data property.
  2091.    It first frees the pointer at index and then stores a pointer to
  2092.    a _copy_ of the passed data into that slot. *)
  2093. Procedure TPointerArray.PutData( index: Cardinal ; value: Pointer );
  2094.   Begin
  2095.     If ValidIndex( index ) Then Begin
  2096.       If ( PPArray( Memory )^[ index ] <> Nil ) and HasFlag( AF_OwnsData ) 
  2097.       Then
  2098.         FreeItem( PPArray( Memory )^[ index ] );
  2099.       PPArray( Memory )^[ index ] := CloneItem( value );
  2100.       SortOrder := TS_NONE;
  2101.     End;
  2102.   End; { TPointerArray.PutData }
  2103.  
  2104. (* returns pointer in slot index, or Nil, if the index is invalid. *)
  2105. Function TPointerArray.GetData(index: Cardinal): Pointer;
  2106.   Begin
  2107.     If ValidIndex( index ) Then
  2108.       Result := PPArray( Memory )^[ index ]
  2109.     Else
  2110.       Result := Nil;
  2111.   End; { TPointerArray.GetData }
  2112.  
  2113. Procedure TPointerArray.FreeItem( item: Pointer );
  2114.   Begin
  2115.     (* this is a nop for this class since we do not know what item
  2116.        points to *)
  2117.   End; { TPointerArray.FreeItem }
  2118.  
  2119. (* calls FreeItem of each of the items in range and sets the item
  2120.    to nil *)
  2121. Procedure TPointerArray.InvalidateItems(atIndex, numItems: Cardinal);
  2122.   Var 
  2123.     n: Cardinal;
  2124.     p: Pointer;
  2125.   Begin
  2126.     If (numItems > 0) and HasFlag( AF_OwnsData ) Then
  2127.     If ValidateBounds( atIndex, numItems ) Then 
  2128.       For n := atIndex To Pred( numItems+atIndex ) Do Begin
  2129.         p:= AsPtr[ n ];
  2130.         If p <> Nil Then Begin
  2131.           FreeItem( p );
  2132.           p := Nil;
  2133.           PutItem(n, p);
  2134.         End;
  2135.       End; { For }
  2136.   End; { TPointerArray.InvalidateItems }
  2137.  
  2138. (* this version of CloneItem does nothing since we have no info on 
  2139.    the memory item points to. A descendent class would override this
  2140.    method to provide a deep copy of item *)
  2141. Function TPointerArray.CloneItem( item: Pointer ): Pointer; 
  2142.   Begin
  2143.     Result := item;
  2144.   End; { TPointerArray.CloneItem }
  2145.   
  2146. (* since we need to save at least the number of items in the array in
  2147.    addition to the data we take the easy way out and realize file
  2148.    save via stream. *)
  2149. Procedure TPointerArray.SaveToFile( Const Filename: String );
  2150.   Var
  2151.     S: TFileStream;
  2152.   Begin
  2153.     S:= TFileStream.Create( Filename, fmCreate );
  2154.     try
  2155.       SaveToStream( S );
  2156.     finally
  2157.       S.Free
  2158.     end;
  2159.   End; { TPointerArray.SaveToFile }
  2160.  
  2161. Procedure TPointerArray.LoadFromFile( Const Filename: String );
  2162.   Var
  2163.     S: TFileStream;
  2164.   Begin
  2165.     S:= TFileStream.Create( Filename, fmOpenRead or fmShareDenyWrite );
  2166.     try
  2167.       LoadFromStream( S );
  2168.     finally
  2169.       S.Free
  2170.     end;
  2171.   End; { TPointerArray.LoadFromFile }
  2172.  
  2173. (* write first the size of the array then call SaveItemToStream for
  2174.    each item *)
  2175. Procedure TPointerArray.SaveToStream( Stream: TStream );
  2176.   Var
  2177. {$IFDEF WIN32}
  2178.     temp: Cardinal;
  2179. {$ELSE}
  2180.     temp: LongInt;
  2181. {$ENDIF}
  2182.     n: Cardinal;
  2183.   Begin
  2184.     temp := Count;
  2185.     With Stream Do Begin
  2186.       Write( temp, Sizeof( temp ));
  2187.       For n := 0 To MaxIndex Do Begin
  2188.         SaveItemToStream( Stream, AsPtr[ n ] );
  2189.       End; { For }
  2190.     End; { With }
  2191.   End; { TPointerArray.SaveToStream }
  2192.  
  2193. Procedure TPointerArray.LoadFromStream( Stream: TStream );
  2194.   Var
  2195. {$IFDEF WIN32}
  2196.     temp: Cardinal;
  2197. {$ELSE}
  2198.     temp: LongInt;
  2199. {$ENDIF}
  2200.     n: Cardinal;
  2201.     P: Pointer;
  2202.   Begin
  2203.     With Stream Do Begin
  2204.       Read( temp, Sizeof( temp ));
  2205.       InvalidateItems( 0, Count );
  2206.       Redim( temp );
  2207.       For n := 0 To MaxIndex Do Begin
  2208.         LoadItemfromStream( Stream, P );
  2209.         (* we use PutItem here because otherwise we would end up
  2210.            with a _copy_ of the data in P^ beeing stored, if
  2211.            CopyItem implements deep copy! *)
  2212.         PutItem( n, P );
  2213.       End; { For }
  2214.     End; { With }
  2215.   End; { TPointerArray.LoadFromStream }
  2216.  
  2217. Procedure TPointerArray.SaveItemToStream( S: TStream; Item: Pointer ); 
  2218.   Begin
  2219.     raise
  2220.       Exception.Create(
  2221.         'Call to abstract method: TPointerArray.SaveItemToStream');
  2222.       (* depends on data stored *)
  2223.   End; { TPointerArray.SaveItemToStream }
  2224.  
  2225. Procedure TPointerArray.LoadItemFromStream( S: TStream; Var Item: Pointer );
  2226.   Begin
  2227.     raise
  2228.       Exception.Create(
  2229.         'Call to abstract method: TPointerArray.LoadItemFromStream');
  2230.   End; { TPointerArray.LoadItemFromStream }
  2231.  
  2232. {+--------------------------
  2233.  | Methods of TPcharArray  
  2234.  +-------------------------}
  2235. Constructor TPcharArray.Create( itemcount, dummy: Cardinal );
  2236.   Begin
  2237.     inherited Create( itemcount, Sizeof( Pointer ));
  2238.     Flags := [ AF_OwnsData, AF_AutoSize, AF_CanCompare ];
  2239.     CompareProc := CmpPChars;
  2240.   End; { TPcharArray.Create }
  2241.  
  2242. Procedure TPcharArray.PutData( index: Cardinal; value: PChar );
  2243.   Begin
  2244.     inherited PutData( index, Pointer( value ));
  2245.   End; { TPcharArray.PutData }
  2246.  
  2247. Function TPcharArray.GetData(index: Cardinal): PChar;
  2248.   Begin
  2249.     Result := inherited GetData( index );
  2250.   End; { TPcharArray.GetData }
  2251.  
  2252. Function TPcharArray.CloneItem( item: Pointer ): Pointer;
  2253.   Begin
  2254.     If HasFlag( AF_OwnsData ) Then
  2255.       If item <> Nil Then
  2256.         Result := StrNew( item )
  2257.       Else
  2258.         Result := Nil
  2259.     Else
  2260.       Result := item;
  2261.   End; { TPcharArray.CloneItem }
  2262.  
  2263. Procedure TPcharArray.FreeItem( item: Pointer );
  2264.   Begin
  2265.     If HasFlag(  AF_OwnsData ) Then 
  2266.       StrDispose( item );
  2267.   End; { TPcharArray.FreeItem }
  2268.  
  2269. Procedure TPcharArray.SaveItemToStream( S: TStream; Item: Pointer );
  2270.   Var
  2271.     pStr: PChar absolute Item;
  2272.     len: Cardinal;
  2273.   Begin
  2274.     (* we write the pchar with length in front and including the
  2275.        terminating zero! *)
  2276.     If item = Nil Then
  2277.       len := 0
  2278.     else
  2279.       len := StrLen( pStr );
  2280.     S.Write( len, Sizeof( Len ));
  2281.     If len > 0 Then
  2282.       S.Write( pStr^, len+1 );
  2283.   End; { TPcharArray.SaveItemToStream }
  2284.  
  2285. Procedure TPcharArray.LoadItemFromStream( S: TStream; Var Item: Pointer );
  2286.   Var
  2287.     len: Cardinal;
  2288.   Begin
  2289.     S.Read( len, Sizeof( len ));
  2290.     If len > 0 Then Begin
  2291.       Item := StrAlloc( len+1 );
  2292.       S.Read( Item^, len+1 );
  2293.     End { If }
  2294.     Else
  2295.       Item := Nil;
  2296.   End; { TPcharArray.LoadItemFromStream }
  2297.  
  2298. Procedure TPcharArray.PutAsString( index: Cardinal; Const value: String );
  2299.   Var 
  2300.     pStr: PChar;
  2301.   Begin
  2302.     pStr := StrAlloc( Length( value )+1 );
  2303.     try
  2304.       StrPCopy( pStr, value );
  2305.       FreeItem( GetData( index ));
  2306.       PutItem( index, pStr );
  2307.     except
  2308.       StrDispose( pStr );
  2309.       raise
  2310.     end;
  2311.   End; { TPcharArray.PutAsString }
  2312.  
  2313. Function TPcharArray.GetAsString(index: Cardinal): String;
  2314.   Var
  2315.     pStr: PChar;
  2316.   Begin
  2317.     pStr := GetData( index );
  2318.     If pStr <> Nil Then 
  2319.       Result := StrPas( pStr )
  2320.     Else
  2321.       Result := EmptyStr;
  2322.   End; { TPcharArray.GetAsString }
  2323.  
  2324. Procedure TPcharArray.PutAsInteger( index: Cardinal; value: LongInt );
  2325.   Begin
  2326.     PutAsString( index, IntToStr( value ));
  2327.   End; { TPcharArray.PutAsInteger }
  2328.  
  2329. Function TPcharArray.GetAsInteger(index: Cardinal): LongInt;
  2330.   Begin
  2331.     try
  2332.       Result := StrToInt( GetAsString( index ));
  2333.     except
  2334.       Result := 0
  2335.     end;
  2336.   End; { TPcharArray.GetAsInteger }
  2337.  
  2338. Procedure TPcharArray.PutAsReal( index: Cardinal; value: Extended );
  2339.   Begin
  2340.     PutAsString( index, FloatToStr( value ));
  2341.   End; { TPcharArray.PutAsReal }
  2342.  
  2343. Function TPcharArray.GetAsReal(index: Cardinal): Extended;
  2344.   Begin
  2345.     try
  2346.       Result := StrToFloat( GetAsString( index ));
  2347.     except
  2348.       Result := 0.0
  2349.     end;
  2350.   End; { TPcharArray.GetAsReal }
  2351.  
  2352. Function GetFileSize( Const Filename: String): LongInt;
  2353.   Var
  2354.     SRec: TSearchRec;
  2355.   Begin
  2356.     If FindFirst( Filename, faAnyfile, SRec ) = 0 Then
  2357.       Result := SRec.Size
  2358.     Else
  2359.       Result := 0;
  2360.     SysUtils.FindClose(SRec);
  2361.   End;
  2362.  
  2363. Procedure TPcharArray.LoadFromTextfile( Const Filename: String;
  2364.                                         appendData: Boolean;
  2365.                                         reporter: TProgressReporter );
  2366.   Type
  2367.     TLine = Array [ 0..$8000 ] Of Char;
  2368.     TBuf  = Array [ 0..$3fff ] of Char;
  2369.   Var
  2370.     pBuf: ^TBuf;
  2371.     F: TextFile;
  2372.     lines, currpos: Cardinal;
  2373.     line: ^TLine;
  2374.     fsize, sum: LongInt;
  2375.     retain: Boolean;
  2376.   Begin
  2377.     (* open file for read *)
  2378.     fsize := GetFilesize(Filename);
  2379.     If fsize = 0 Then Exit;
  2380.  
  2381.     AssignFile( F, Filename );
  2382.     pBuf := Nil;
  2383.     New(pBuf);
  2384.     try
  2385.       System.SetTextBuf( F, pBuf^, Sizeof( pBuf^ ));
  2386.       Reset( F );
  2387.       line := Nil;
  2388.       try
  2389.         New( line );
  2390.         (* prepare array by blasting all items in it if we are not
  2391.            asked to append the new data, set currpos to the first
  2392.            index we put new data in *)
  2393.         If not appendData Then Begin
  2394.           Zap;
  2395.           currpos := 0;
  2396.         End { If }
  2397.         Else
  2398.           currpos := Count;
  2399.         (* get a very rough estimate of the number of lines in the file *)
  2400.         If (LongInt(MaxCapacity)*20) < FSize Then
  2401.           lines := MaxCapacity
  2402.         Else
  2403.           lines := FSize div 20;
  2404.  
  2405.         (* resize the array so the new lines will ( hopefully ) fit without
  2406.            to many redims in between *)
  2407.         If appendData Then
  2408.           Redim( Count+lines )
  2409.         Else
  2410.           Redim( lines );
  2411.  
  2412.         (* now start reading lines *)
  2413.         sum := 0;
  2414.         While not Eof( F ) Do Begin
  2415.           ReadLn( F, line^ );
  2416.           If currpos = Capacity Then
  2417.             If currpos = MaxCapacity Then
  2418.               raise EFileTooLarge.CreateFmt( ErrFileTooLarge, [filename]  )
  2419.             Else
  2420.               Redim( Capacity+100 );
  2421.           PutData( currpos, PChar(line) );
  2422.           If @reporter <> Nil Then Begin
  2423.             sum := sum+StrLen( PChar(line) )+2;
  2424.             If not reporter( sum, fsize, retain ) Then Begin
  2425.               If not retain Then
  2426.                 Delete( 0, currpos+1 );
  2427.               Break;
  2428.             End;
  2429.           End;
  2430.           Inc( currpos );
  2431.         End; { While }
  2432.         If currpos < Capacity Then
  2433.           Redim( currpos );
  2434.       finally
  2435.         CloseFile( F );
  2436.         If line <> Nil Then
  2437.           Dispose( line );
  2438.       end;
  2439.     finally
  2440.       Dispose( pBuf );
  2441.     end;
  2442.   End; { TPcharArray.LoadFromTextfile }
  2443.  
  2444. Procedure TPcharArray.SaveToTextfile( Const Filename: String;
  2445.                                        appendData: Boolean;
  2446.                                        reporter: TProgressReporter );
  2447.   Type
  2448.     TBuf  = Array [ 0..$3fff ] of Char;
  2449.   Var
  2450.     pBuf: ^TBuf;
  2451.     F: TextFile;
  2452.     n: Cardinal;
  2453.     total, sum: LongInt;
  2454.     retain: Boolean;
  2455.     p: PChar;
  2456.   Begin
  2457.     (* calculate total size of text to save, including CR-LF lineends *)
  2458.     total := 0;
  2459.     For n := 0 To Count-1 Do Begin
  2460.       p := Data[ n ];
  2461.       If p <> Nil Then
  2462.         total := total + StrLen( p ) + 2
  2463.       Else
  2464.         Inc( total, 2 );  (* nil strings produce an empty line in the file *)
  2465.     End; { For }
  2466.     (* assign the file and give it a text buffer to speed up file I/O *)
  2467.     AssignFile( F, Filename );
  2468.     pBuf := Nil;
  2469.     New(pBuf);
  2470.     try
  2471.       System.SetTextBuf( F, pBuf^, Sizeof( pBuf^ ));
  2472.       (* open the file *)
  2473.       If appendData Then
  2474.         System.Append( F )
  2475.       Else
  2476.         System.Rewrite( F );
  2477.       try
  2478.         (* write the text *)
  2479.         sum := 0;
  2480.         retain := True;
  2481.         For n := 0 To Count-1 Do Begin
  2482.           p := Data[ n ];
  2483.           If p <> Nil Then
  2484.             WriteLn( F, p )
  2485.           Else
  2486.             WriteLn( F );
  2487.           (* report progress if someone is listening *)
  2488.           If @reporter <> Nil Then Begin
  2489.             If p <> Nil Then
  2490.               sum := sum+StrLen( p )+2
  2491.             Else
  2492.               Inc( sum, 2 );
  2493.             If not reporter( sum, total, retain ) Then
  2494.               break;
  2495.           End; { If }
  2496.         End; { For }
  2497.       finally
  2498.         CloseFile( F );
  2499.         If not retain Then
  2500.           Erase( F );
  2501.       end;
  2502.     finally
  2503.       Dispose( pBuf );
  2504.     end;
  2505.   End; { TPcharArray.SaveToTextfile }
  2506.  
  2507. {+--------------------------
  2508.  | Methods of TPStringArray
  2509.  +-------------------------}
  2510. Constructor TPStringArray.Create( itemcount, dummy: Cardinal );
  2511.   Begin
  2512.     inherited Create( itemcount, Sizeof( Pointer ));
  2513.     Flags := [ AF_OwnsData, AF_AutoSize, AF_CanCompare ];
  2514.     CompareProc := CmpPStrings;
  2515.   End; { TPStringArray.Create }
  2516.  
  2517. Procedure TPStringArray.PutData( index: Cardinal; Const value: String );
  2518.   Begin
  2519.     inherited PutData( index, @value )
  2520.   End; { TPStringArray.PutData }
  2521.  
  2522. Function TPStringArray.GetData(index: Cardinal): String;
  2523.   Var
  2524.     p: Pointer;
  2525.   Begin
  2526.     p := inherited GetData( index );
  2527.     If p = Nil Then
  2528.       Result := EmptyStr
  2529.     Else
  2530.       Result := PString( p )^;
  2531.   End; { TPStringArray.GetData }
  2532.  
  2533. Function TPStringArray.GetAsPtr(index: Cardinal): PString;
  2534.   Begin
  2535.     Result := PString( inherited GetData( index ));
  2536.   End; { TPStringArray.GetAsPtr }
  2537.  
  2538.  
  2539. Function TPStringArray.CloneItem( item: Pointer ): Pointer;
  2540.   Begin
  2541.     If HasFlag( AF_OwnsData ) Then
  2542.       If item <> Nil Then
  2543.         Result := NewStr( PString( item )^ )
  2544.       Else
  2545.         Result := Nil
  2546.     Else
  2547.       Result := item;
  2548.   End; { TPStringArray.CloneItem }
  2549.  
  2550. Procedure TPStringArray.FreeItem( item: Pointer );
  2551.   Begin
  2552.     If HasFlag(  AF_OwnsData ) Then 
  2553.       DisposeStr( PString( item ));
  2554.   End; { TPStringArray.FreeItem }
  2555.  
  2556. Procedure TPStringArray.SaveItemToStream( S: TStream; Item: Pointer );
  2557.   Var
  2558.     len: Cardinal;
  2559.   Begin
  2560.     If  item = Nil Then 
  2561.       len := 0
  2562.     else
  2563.       len := Length( PString( item )^ );
  2564.     If len > 0 Then
  2565.       S.Write( Item^, len+1 )
  2566.     Else
  2567.       S.Write( len, 1 );
  2568.   End; { TPStringArray.SaveItemToStream }
  2569.  
  2570. Procedure TPStringArray.LoadItemFromStream( S: TStream; Var Item: Pointer );
  2571.   Var
  2572.     Str  : String;
  2573.   Begin
  2574.     S.Read( Str, 1 );
  2575.     If Length( Str ) > 0 Then
  2576.       S.Read( Str[ 1 ], Length( Str ));
  2577.     Item := NewStr( Str );
  2578.   End; { TPStringArray.LoadItemFromStream }
  2579.  
  2580. Procedure TPStringArray.PutAsPChar( index: Cardinal; value: PChar );
  2581.   Begin
  2582.     If value = Nil Then 
  2583.       PutData( index, EmptyStr )
  2584.     Else
  2585.       PutData( index, StrPas( value ));
  2586.   End; { TPStringArray.PutAsPChar }
  2587.  
  2588. Function TPStringArray.GetAsPChar(index: Cardinal): PChar;
  2589.   Var
  2590.     pStr: PString;
  2591.   Begin
  2592.     pStr := GetAsPtr( index );
  2593.     If pStr = Nil Then
  2594.       Result := Nil
  2595.     Else Begin
  2596.       Result := StrAlloc( Length( pStr^ )+1 );
  2597.       StrPCopy( Result, pStr^ );
  2598.     End;
  2599.   End; { TPStringArray.GetAsPChar }
  2600.  
  2601. Procedure TPStringArray.PutAsInteger( index: Cardinal; value: LongInt );
  2602.   Begin
  2603.     PutData( index, IntToStr( value ));
  2604.   End; { TPStringArray.PutAsInteger }
  2605.  
  2606. Function TPStringArray.GetAsInteger(index: Cardinal): LongInt;
  2607.   Begin
  2608.     try
  2609.       Result := StrToInt( GetData( index ));
  2610.     except
  2611.       Result := 0;
  2612.     end;
  2613.   End; { TPStringArray.GetAsInteger }
  2614.  
  2615. Procedure TPStringArray.PutAsReal( index: Cardinal; value: Extended );
  2616.   Begin
  2617.     PutData( index, FloatToStr( value ));
  2618.   End; { TPStringArray.PutAsReal }
  2619.  
  2620. Function TPStringArray.GetAsReal(index: Cardinal): Extended;
  2621.   Begin
  2622.     try
  2623.       Result := StrToFloat( GetData( index ));
  2624.     except
  2625.       Result := 0.0;
  2626.     end;
  2627.   End; { TPStringArray.GetAsReal }
  2628.  
  2629. Procedure TPStringArray.LoadFromTextfile( Const Filename: String;
  2630.                                         appendData: Boolean;
  2631.                                         reporter: TProgressReporter );
  2632.   Type
  2633.     TBuf  = Array [ 0..$3fff ] of Char;
  2634.   Var
  2635.     pBuf: ^TBuf;
  2636.     F: TextFile;
  2637.     lines, currpos: Cardinal;
  2638.     line: String;
  2639.     fsize: LongInt;
  2640.     sum: LongInt;
  2641.     retain: Boolean;
  2642.   Begin
  2643.     (* open file for read *)
  2644.     fsize := GetFilesize(Filename);
  2645.     If fsize = 0 Then Exit;
  2646.  
  2647.     AssignFile( F, Filename );
  2648.     pBuf := Nil;
  2649.     New(pBuf);
  2650.     try
  2651.       System.SetTextBuf( F, pBuf^, Sizeof( pBuf^ ));
  2652.       Reset( F );
  2653.       try
  2654.         (* prepare array by blasting all items in it if we are not
  2655.            asked to append the new data, set currpos to the first
  2656.            index we put new data in *)
  2657.         If not appendData Then Begin
  2658.           Zap;
  2659.           currpos := 0;
  2660.         End { If }
  2661.         Else
  2662.           currpos := Count;
  2663.  
  2664.         (* get a very rough estimate of the number of lines in the file. *)
  2665.         If (LongInt(MaxCapacity)*20) < FSize Then
  2666.           lines := MaxCapacity
  2667.         Else
  2668.           lines := FSize div 20;
  2669.  
  2670.         (* resize the array so the new lines will ( hopefully ) fit without
  2671.            to many redims in between *)
  2672.         If appendData Then
  2673.           Redim( Count+lines )
  2674.         Else
  2675.           Redim( lines );
  2676.  
  2677.         (* now start reading lines *)
  2678.         sum := 0;
  2679.         While not Eof( F ) Do Begin
  2680.           ReadLn( F, line );
  2681.           If currpos = Capacity Then
  2682.             If currpos = MaxCapacity Then
  2683.               raise EFileTooLarge.CreateFmt( ErrFileTooLarge, [filename]  )
  2684.             Else
  2685.               Redim( Capacity+100 );
  2686.           PutData( currpos, line );
  2687.           If @reporter <> Nil Then Begin
  2688.             sum := sum+Length( line )+2;
  2689.             If not reporter( sum, fsize, retain ) Then Begin
  2690.               If not retain Then
  2691.                 Delete( 0, currpos+1 );
  2692.               Break;
  2693.             End;
  2694.           End;
  2695.           Inc( currpos );
  2696.         End; { While }
  2697.         If currpos < Capacity Then
  2698.           Redim( currpos );
  2699.       finally
  2700.         CloseFile( F );
  2701.       end;
  2702.     finally
  2703.       Dispose(pBuf);
  2704.     end;
  2705.   End; { TPStringArray.LoadFromTextfile }
  2706.  
  2707. Procedure TPStringArray.SaveToTextfile( Const Filename: String;
  2708.                                        appendData: Boolean;
  2709.                                        reporter: TProgressReporter );
  2710.   Type
  2711.     TBuf  = Array [ 0..$3fff ] of Char;
  2712.   Var
  2713.     pBuf: ^TBuf;
  2714.     F: TextFile;
  2715.     n: Cardinal;
  2716.     total, sum: LongInt;
  2717.     retain: Boolean;
  2718.     p: PString;
  2719.   Begin
  2720.     (* calculate total size of text to save, including CR-LF lineends *)
  2721.     total := 0;
  2722.     For n := 0 To Count-1 Do Begin
  2723.       p := AsPString[n];
  2724.       If p <> Nil Then
  2725.         total := total + Length( p^ ) + 2
  2726.       Else
  2727.         Inc( total, 2 );  (* nil strings produce an empty line in the file *)
  2728.     End; { For }
  2729.     AssignFile( F, Filename );
  2730.     pBuf := Nil;
  2731.     New(pBuf);
  2732.     try
  2733.       System.SetTextBuf( F, pBuf^, Sizeof( pBuf^ ));
  2734.       If appendData Then
  2735.         System.Append( F )
  2736.       Else
  2737.         System.Rewrite( F );
  2738.       try
  2739.         (* write the text *)
  2740.         sum := 0;
  2741.         retain := True;
  2742.         For n := 0 To Count-1 Do Begin
  2743.           p := AsPString[n];
  2744.           If p <> Nil Then
  2745.             WriteLn( F, p^ )
  2746.           Else
  2747.             WriteLn( F );
  2748.           (* report progress if someone is listening *)
  2749.           If @reporter <> Nil Then Begin
  2750.             If p <> Nil Then
  2751.               sum := sum+Length( p^ )+2
  2752.             Else
  2753.               Inc( sum, 2 );
  2754.             If not reporter( sum, total, retain ) Then
  2755.               break;
  2756.           End; { If }
  2757.         End; { For }
  2758.       finally
  2759.         CloseFile( F );
  2760.         If not retain Then
  2761.           Erase( F );
  2762.       end;
  2763.     finally
  2764.       Dispose( pBuf );
  2765.     end;
  2766.   End; { TPStringArray.SaveToTextfile }
  2767. {+----------------------
  2768.  | Auxillary procedures
  2769.  +----------------------}
  2770. Function CmpIntegers( Var item1, item2 ): Integer; 
  2771.   Var
  2772.     i1: Integer absolute item1;
  2773.     i2: Integer absolute item2;
  2774.   Begin
  2775.     Result := i1-i2;
  2776.   End;
  2777.  
  2778. Function CmpCardinals( Var item1, item2  ): Integer; 
  2779.   Var
  2780.     i1: Cardinal absolute item1;
  2781.     i2: Cardinal absolute item2;
  2782.   Begin
  2783.     If i1 < i2 Then 
  2784.       Result := -1
  2785.     Else
  2786.       If i1 > i2 Then
  2787.         Result := 1
  2788.       Else
  2789.         Result := 0;
  2790.   End;
  2791.  
  2792. Function CmpLongs( Var item1, item2 ): Integer;
  2793.   Var
  2794.     i1: LongInt absolute item1;
  2795.     i2: LongInt absolute item2;
  2796.   Begin
  2797.     If i1 < i2 Then 
  2798.       Result := -1
  2799.     Else
  2800.       If i1 > i2 Then
  2801.         Result := 1
  2802.       Else
  2803.         Result := 0;
  2804.   End;
  2805.  
  2806. Function CmpReals( Var item1, item2 ): Integer;
  2807.   Var
  2808.     i1: Real absolute item1;
  2809.     i2: Real absolute item2;
  2810.     r: Real;
  2811.   Begin
  2812.     r := i1-i2;
  2813.     If Abs( r ) < 1.0E-30 Then
  2814.       result := 0
  2815.     Else
  2816.       If r < 0 Then
  2817.         result := -1
  2818.       Else
  2819.         result := 1;
  2820.   End;
  2821.  
  2822. Function CmpSingles(Var item1, item2 ): Integer;
  2823.   Var
  2824.     i1: Single absolute item1;
  2825.     i2: Single absolute item2;
  2826.     r: Single;
  2827.   Begin
  2828.     r := i1-i2;
  2829.     If Abs( r ) < 1.0E-30 Then
  2830.       result := 0
  2831.     Else
  2832.       If r < 0 Then
  2833.         result := -1
  2834.       Else
  2835.         result := 1;
  2836.   End;
  2837.  
  2838. Function CmpDoubles(Var item1, item2 ): Integer;
  2839.   Var
  2840.     i1: Double absolute item1;
  2841.     i2: Double absolute item2;
  2842.     r: Double;
  2843.   Begin
  2844.     r := i1-i2;
  2845.     If Abs( r ) < 1.0E-100 Then
  2846.       result := 0
  2847.     Else
  2848.       If r < 0 Then
  2849.         result := -1
  2850.       Else
  2851.         result := 1;
  2852.   End;
  2853.  
  2854. Function CmpExtendeds( Var item1, item2 ): Integer;
  2855.   Var
  2856.     i1: Extended absolute item1;
  2857.     i2: Extended absolute item2;
  2858.     r: Extended;
  2859.   Begin
  2860.     r := i1-i2;
  2861.     If Abs( r ) < 1.0E-3000 Then
  2862.       result := 0
  2863.     Else
  2864.       If r < 0 Then 
  2865.         result := -1
  2866.       Else
  2867.         result := 1;
  2868.   End;
  2869.  
  2870. Function CmpPChars( Var item1, item2 ): Integer;
  2871.   Var
  2872.     p1: PChar absolute item1;
  2873.     p2: PChar absolute item2;
  2874.   Begin
  2875.     Result := lstrcmp( p1, p2 );
  2876.   End;
  2877.  
  2878. Function CmpPStrings( Var item1, item2 ): Integer;
  2879.   Var
  2880.     p1: PString absolute item1;
  2881.     p2: PString absolute item2;
  2882.   Begin
  2883.     Result := AnsiCompareStr( p1^, p2^ );
  2884.   End;
  2885.  
  2886. End.
  2887.